Related
I have an excel sheet full of data sections, each data section is separated by an empty row.
While I'm looping over each row of the worksheet, I need to find the index of the next blank row so I can know where the current data section ends & apply modifications to it before passing to the next data section.
Here is an example of my first loop (inside this loop I need to find the index of the next blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1").Select
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
'''Here I need to add another loop to find the index of my next blank row please'''
idxblankrow = Range(Cells(x, "A")).CurrentRegion.Row
MsgBox "Idx blank row is " & idxblkrow
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Here is another failed attempt(the second nest For loop is what tries to search for the blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
For j = x To lastrow
If IsEmpty(Cells(j, "A")) Then idxblankrow = Cells(j, "A").Row
MsgBox "blank row " & idxblankrow
Exit For
End If
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Any kind of help would be hella appreciated, thanks !
Please, use the next adapted way. It does not select, it does not use clipboard:
For x = 1 To LastRow
If left(cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(cells(x, "H"))) Then
idxblankrow = cells(x, "A").End(xlDown).Row
MsgBox "Idx blank row is " & idxblankrow
Range(cells(x + 2, "A"), cells(idxblankrow - 1, "H")).Cut cells(x + 2, "B")
'copy the value from "H" on the whole A:A column portion:
Range("A" & x & ":A" & idxblankrow - 1).Value = cells(x, "H").Value 'not using clipboard...
Stop 'check when stopped here if it did what you need
'if so, please press F5 to continue and check again.
'you probably need to increment x to continue iteration after the processed portion
'something as:
x = x + (idxblankrow - x) + 2 '???
End If
Next x
You probably need now to increment x with the number of rows which have been processed, but you must explain in words what you try accomplishing. Guessing is not an appropriate way of working here...
If I want to know if an entire row is empty, I just concatenate the whole row and check the length. If this is zero, then the row is blank. Else, it's not.
See following exemplary screenshot (only the fourth row is empty, which is seen in the fourth formula, giving zero as a result):
Use flags to identify the start and end of the group. This deals with multiple blank rows between groups.
Sub macro()
Dim ws As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim x As Long, z As Long
Dim bStart As Boolean, bEnd As Boolean
Set ws = ThisWorkbook.Sheets("Sheet1")
n = 0
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
' start of group
If Len(.Cells(i, "A")) > 0 Then
bStart = True
n = n + 1
End If
' end of group look ahead
If Len(.Cells(i + 1, "A")) = 0 Then
bEnd = bStart
End If
' valid range
If bStart And bEnd Then
x = i - n + 1 ' first row of group
MsgBox "Processing rows " & x & " to " & i
If Left(.Cells(x, "A").Value, 8) = "!JOURNAL" _
And Not (IsEmpty(Cells(x, "H"))) Then
' process rows x to i
End If
' reset flags
n = 0
bStart = False
bEnd = False
End If
Next
End With
End Sub
All these answers could be much simpler. Consider this:
iNextBlankRow = Sheet1.Range("A" & iNextBlankRow & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
To demonstrate, run this macro:
Sub BlankRowTest()
Dim iNextBlankRow As Long
Dim r As Long
iNextBlankRow = 1
For r = 1 To 50
If iNextBlankRow <= r Then iNextBlankRow = Sheet1.Range("A" & iNextBlankRow + 1 & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
Debug.Print r, iNextBlankRow, "'" & Sheet1.Cells(r, 1).Value & "'"
Next
End Sub
This code loops through the first 50 rows looking for the next blank row. When it finds it, it assigns it to the variable iNextBlankRow. We don't bother updating that until our current row (r) is greater than or equal to INextBlankRow. At that point we look again starting from the next row.
At work I am working on a macro/UserForm in Excel for someone. It's worked great on spreadsheets with 15k rows, but takes about 10 minutes to run, while Excel appears to be frozen (not responding). We've tried to run it on a 250k row sheet for about 8 hours and it never completed.
Is there a way to make it more effecient, or at least allow the user to see view its progress without Excel being locked up?
About the Macro
Users are asigned tasks, and arn't supposed to be assigned the same one within 365 days. There are 47 Columens and 250k Rows of users. Rows are sorted by username, create date, task. The macro goes row by row to first make sure its the same user, and then find instances of a task being asigned within the 365 day window, and flagging the row red. Then it checks the next row against the initial to make sure its also not within 365 days.
After reading a few dozens other posts, I'm not sure if this is the most effecient way of doing it. Iif you see anyway to make my code more efficient that would be greatly appreciated!
Sub highlight_newer_dates_v2()
Dim i As Long, j As Long
Dim lastRow As Long
Dim AccountNo As String, SpecialtyTo As String, CreateDate1 As Date, CreateDate2 As Date
Dim lastNonRedRow As Long
lastRow = Cells(Rows.Count, "I").End(xlUp).Row
lastNonRedRow = 0
For i = 2 To lastRow
AccountNo = Cells(i, 9).Value
SpecialtyTo = Cells(i, 13).Value
CreateDate1 = Cells(i, 5).Value
If Cells(i, 9).Interior.Color = RGB(255, 0, 0) Then
If lastNonRedRow = 0 Then
For j = i - 1 To 2 Step -1
If Cells(j, 9).Interior.Color <> RGB(255, 0, 0) Then
lastNonRedRow = j
Exit For
End If
Next j
End If
If lastNonRedRow <> 0 Then
CreateDate1 = Cells(lastNonRedRow, 5).Value
End If
Else
lastNonRedRow = i
End If
For j = i + 1 To lastRow
If Cells(j, 9).Value = AccountNo And Cells(j, 13).Value = SpecialtyTo Then
CreateDate2 = Cells(j, 5).Value
If Abs(CreateDate2 - CreateDate1) <= 365 Then
If CreateDate2 > CreateDate1 Then
Rows(j).Interior.Color = RGB(255, 0, 0)
Else
Rows(i).Interior.Color = RGB(255, 0, 0)
End If
End If
End If
Next j
Next i
End Sub
I've tried doing a loop to make it more effecient but couldn't get it to work properly.
Looping through row by row in vba is going to be inefficient. If I am understanding your problem correctly, you should 1. sort by date 2. sort by task 3 sort by user 4. use the formulas below. You would have to add even more columns if you might have more than 3 sequences, but its a pattern. You could also have vba sort by these values, put in the formulas, past the any true column as values and then sort back to your original order.
SEQUNCE
=COUNTIFS($A$5:A5,A5,$B$5:B5,B5)
2nd too close to 1st
=IF(AND(D6=2,(C6-C5)<365),1,0)
3rd too close to 2nd
=IF(AND(D7=3,(C7-C6)<365,E6=0),1,0)
ANY TRUE
=MAX(E5:F5)
Process 15,000 rows in a few seconds, 250,000 in < 1 minute.
Option Explicit
Sub highlight_newer_dates_v4()
Const COLS = 47
Dim ws As Worksheet
Dim dictTask, k, colDates As Collection
Dim bRed() As Boolean
Dim lastrow As Long, i As Long, j As Long
Dim n As Long, r As Long, r1 As Long, r2 As Long
Dim dt As Date, dt1 As Date, dt2 As Date
Dim task As String, accno As String
Dim t0 As Single
' store task and dates for one account
Set dictTask = CreateObject("Scripting.Dictionary")
' specify your sheet here
Set ws = ThisWorkbook.Sheets("Testdata")
'Call testData(ws, 250000)
' process data sheet
t0 = Timer
Application.ScreenUpdating = False
With ws
lastrow = .Cells(.Rows.Count, "I").End(xlUp).Row
ReDim bRed(1 To lastrow)
For r = 2 To lastrow
accno = Trim(.Cells(r, 9)) 'I
task = Trim(.Cells(r, 13)) 'M
dt = CDate(.Cells(r, 5)) 'E
' store tasks in dictionary
If Not dictTask.exists(task) Then
dictTask.Add task, New Collection
n = n + 1
End If
dictTask(task).Add Array(r, dt)
' is ths last task for person then check dates
If (.Cells(r + 1, 9)) <> accno Then
For Each k In dictTask
task = CStr(k)
Set colDates = dictTask(k)
' check interval for all permutations
' is > 365 days
For i = 1 To colDates.Count - 1
r1 = colDates(i)(0)
dt1 = colDates(i)(1)
dt = DateAdd("d", 365, dt1) '365 days later
If bRed(r1) = False Then
For j = i + 1 To colDates.Count
' color rows red if <= 365
r2 = colDates(j)(0)
dt2 = colDates(j)(1)
If bRed(r2) = False And dt2 <= dt Then
bRed(r2) = True
'.Cells(r2, 1).Resize(, COLS).Interior.Color = vbRed
.Cells(r2, 1).Interior.Color = vbYellow
End If
Next
End If
Next
Next
' clear data for next account
dictTask.RemoveAll
n = 0
End If
Next
End With
Application.ScreenUpdating = True
' result
MsgBox Format(lastrow, "0,000") & " rows scanned in " _
& Format(Timer - t0, "0.0 secs")
End Sub
Sub testData(maxrow As Long, ws As Worksheet)
Const USERS = 99
Dim TaskCount As Long
TaskCount = Int(maxrow / USERS)
Dim n As Long, t0 As Single: t0 = Timer
Application.ScreenUpdating = False
With ws
.Cells.Clear
.Columns("E:E").NumberFormat = "dd-mmm-yyyy"
.Range("E1") = "Date"
.Range("I1") = "AccNo"
.Range("M1") = "Task"
For n = 2 To maxrow
.Cells(n, 5) = DateAdd("d", 1000 * Rnd(), DateSerial(2020, 1, 1))
.Cells(n, 9) = "ID_" & Format(Rnd() * USERS + 1, "000")
.Cells(n, 13) = "Task_" & Format(Rnd() * TaskCount + 1, "0000")
Next
.Columns.AutoFit
' sort username, create date, task
With .Sort
With .SortFields
.Clear
.Add2 Key:=Range("I1:I" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add2 Key:=Range("E1:E" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add2 Key:=Range("M1:M" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange Range("E1:M" & maxrow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.ScreenUpdating = True
MsgBox Format(maxrow, "0,000") & " rows created in " & Format(Timer - t0, "0.0 secs")
End Sub
I have a WorksheetFunction.SumIfs with 3 Args code being applied in so many cells (10k rows x 20 columns), it ran for 2 hours to get complete, but when I do the same but with formula in excel and drag and drop until last column and line, it goes much faster (less than 10min).
I have already done xlCalculationManual. do you have any idea on how to improve processing time in VBA?
Code:
application.calculation= xlCalculationManual
for Col = 3 to 22
for Row = 2 to 10000
FileA.Cells(Row, Col).Value = Application.WorksheetFunction.SumIfs(FileB.Range("A:A"), FileB.Range("D:D"), FileA.Range("A" & Row).Value, FileB.Range("B:B"), FileA.Range("B" & Row).Value, FileB.Range("C:C"), FileA.Cells(1, Col).Value)
Next
Next
SOLUTION:
I found a simple solution by myself. In a big range of data, instead of using Application.WorksheetFunction.FUNCTION_NAME inside FOR, use Book.Sheet.Range().Formula = "=Formula(Parameters)" in the first Cell, then use .Copy, then .PasteSpecial Paste:=xlPasteFormulas, examples below:
' Takes 2h
for Col = 3 to 22
for Row = 2 to 10000
FileA.Cells(Row, Col).Value = Application.WorksheetFunction.SumIfs(FileB.Range("A:A"), FileB.Range("D:D"), FileA.Range("A" & Row).Value, FileB.Range("B:B"), FileA.Range("B" & Row).Value, FileB.Range("C:C"), FileA.Cells(1, Col).Value)
Next
Next
' Takes 10min
application.calculation= xlCalculationManual
FileA.Cells(2, 3).Formula = "=SUMIFS([FileB.XLSX]Sheet1!$A:$A,[FileB.XLSX]Sheet1!$D:$D,$A2,[FileB.XLSX]Sheet1!$B:$B,$B2,[FileB.XLSX]Sheet1!$C:$C,C$1)"
FileA.Cells(2, 3).Copy
FileA.Range(FileA.Cells(2, 3), FileA.Cells(10000, 22)).PasteSpecial Paste:=xlPasteFormulas
application.calculation= xlCalculationAutomatic
As per my comments, use variant arrays and loop the range once.
Sub mysumif()
Dim fileA As Worksheet
Set fileA = Worksheets("Sheet2")
Dim fileB As Worksheet
Set fileB = Worksheets("Sheet1")
Dim rngArr As Variant
rngArr = Intersect(fileB.Range("A:D"), fileB.UsedRange)
Dim Bclm As Variant
Bclm = Intersect(fileA.Range("A2:B100000"), fileA.UsedRange)
Dim ttlRos As Variant
ttlRos = Intersect(fileA.Range("C1:ZZ1"), fileA.UsedRange)
Dim otptArr As Variant
ReDim otptArr(1 To UBound(Bclm, 1), 1 To UBound(ttlRos, 2))
Dim i As Long
For i = 1 To UBound(rngArr, 1)
Dim j As Variant
j = Application.Match(rngArr(i, 3), ttlRos, 0)
If Not IsError(j) Then
Dim k As Long
For k = 1 To UBound(Bclm, 1)
If Bclm(k, 1) = rngArr(i, 4) And Bclm(k, 2) = rngArr(i, 2) Then
otptArr(k, j) = otptArr(k, j) + rngArr(i, 1)
Exit For
End If
Next k
End If
Next i
fileA.Range("C2").Resize(UBound(otptArr, 1), UBound(otptArr, 2)).Value = otptArr
End Sub
Before:
After:
Also note that a pivot table can do this also much quicker:
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
I have different test dates and times that can be up to about 100 tests each time point. I received the data that was only a single column that consists of thousands of rows, which should have been delivered in a matrix type grid.
I have only copied a sample, which has 6 time points and up to 4 tests each. I need Excel to "recognize" when there is only a date/time in a cell, then copy that cell to the next date/time to paste in a new sheet and column.
Eventually, I was hoping to also have the Title of the test separated from the results. However, if this is not plausible without knowing the name of every test, I can skip it. This is the data I start with:
Title
01/02/2010 0:03
Ounces: 10.87
Concentration: 6.89 (L)
Expiration Date: 11/2/2019 5:47:00
01/06/2011 2:06
Ounces: 18.09
Concentration: 10.7 (H)
Expiration Date: 11/2/2019 5:47:00
Other: Resampled
01/06/2011 2:06
Ounces: 12.87
Concentration: 10.9 (H)
Expiration Date: 11/2/2019 5:47:00
Other: 2nd Sample
09/15/2012 7:07
Ounces: 8.53
Concentration: 9.72
Expiration Date: 12/5/2019 4:45:00
05/02/2013 15:52
Ounces: 11.62
Concentration: 8.42
05/09/2017 1:45
Ounces: 9.34
Concentration: 8.98
I created the following Excel VBA, but am still new at programming, especially loops within loops, so I could not figure out how to create the offset that is dynamic enough to both select the right cells, but to copy them over to a new column. I also have redundancy within the code.
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long
sSheet = ActiveSheet.Name
Sheets.Add
dSheet = ActiveSheet.Name
With Worksheets("Sheet1")
' All Data is in Column A
NumberofTasks = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = 1 To NumberofTasks
Sheets(sSheet).Activate
If IsDate(.Range("A" & x).Value) Then '<-- check if current cell at Column A is Date
Range(Cells(x, 1), Cells(x, 1).Offset(4, 0)).Select
Selection.Copy
Sheets(dSheet).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveCell.Offset(1, 0).Select
End If
Next x
End With
End Sub
This is what I hoped would happen (but on a much larger scale):
However, the offset places another date in another cell with the current code. Thank you for any help you can provide me.
There are many ways to skin a cat. Here is one way using arrays which is much much faster than looping through the range
Worksheet:
I am for the sake of coding, assuming that the data is in Sheet1 and looks like below
Logic:
Store the data from the worksheet in an array; Let's call it InputArray
Create an output array for storing data; Let's call it OutputArray
Loop through InputArray and find the date and then find the rest of the records. store in OutputArray
direct the output from OutputArray to the relevant worksheet.
Code:
Option Explicit
Sub Sample()
Dim InputArray As Variant
Dim ws As Worksheet
Dim i As Long
Dim recCount As Long
Dim lRow As Long
Dim OutputArray() As String
'~~> Set relevant input sheet
Set ws = Sheet1
With ws
'~~> Find Last Row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Store col A in array
InputArray = .Range("A1:A" & lRow).Value
'~~> Find Total number of records
For i = LBound(InputArray) To UBound(InputArray)
If IsDate(InputArray(i, 1)) Then recCount = recCount + 1
Next i
'~~> Create an array for output
ReDim OutputArray(1 To 5, 1 To recCount + 1)
recCount = 2
'~~> Fill Col A of output array
OutputArray(1, 1) = "Title"
OutputArray(2, 1) = "Ounces"
OutputArray(3, 1) = "Concentration"
OutputArray(4, 1) = "Expiration Date"
OutputArray(5, 1) = "Other"
'~~> Loop through input array
For i = UBound(InputArray) To LBound(InputArray) Step -1
If IsDate(InputArray(i, 1)) Then '< Check if date
OutputArray(1, recCount) = InputArray(i, 1)
'~~> Check for Ounces and store in array
If i + 1 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 1, 1)), 2)) = "OU" _
Then OutputArray(2, recCount) = Trim(Replace(InputArray(i + 1, 1), "Ounces:", ""))
'~~> Check for Concentration and store in array
If i + 2 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 2, 1)), 2)) = "CO" _
Then OutputArray(3, recCount) = Trim(Replace(InputArray(i + 2, 1), "Concentration:", ""))
'~~> Check for Expiration Date and store in array
If i + 3 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 3, 1)), 2)) = "EX" _
Then OutputArray(4, recCount) = Trim(Replace(InputArray(i + 3, 1), "Expiration Date:", ""))
'~~> Check for Other and store in array
If i + 4 < UBound(InputArray) + 1 Then _
If UCase(Left(Trim(InputArray(i + 4, 1)), 2)) = "OT" _
Then OutputArray(5, recCount) = Trim(Replace(InputArray(i + 4, 1), "Other:", ""))
recCount = recCount + 1
End If
Next i
End With
'~~> Output it to relevant sheet
Sheet2.Range("A1").Resize(5, recCount - 1).Value = OutputArray
End Sub
Output:
I think here is better way to do it using Range.Find
Assuming the Data is in 1st Column of Sheet1 ie. Column A
In Demo the Expiration Date is not right, I have corrected that in the Code.
Try this code:
Sub TP()
Dim wk As Worksheet: Set wk = ThisWorkbook.Worksheets("Sheet1")
Dim lr As Long: lr = wk.Cells(wk.Rows.Count, "A").End(xlUp).row
Dim rng As Range
Dim i As Long
Dim j As Long
j = 4
For i = 3 To lr
Set rng = wk.Range(Cells(i, 1), Cells(i, 1).End(xlDown))
wk.Cells(2, j).Value = rng.Cells(1, 1).Value
Set fnd = rng.Find("Ounces")
If Not fnd Is Nothing Then wk.Cells(3, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Concentration")
If Not fnd Is Nothing Then wk.Cells(4, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
Set fnd = rng.Find("Expiration")
If Not fnd Is Nothing Then wk.Cells(5, j).Value = Right(fnd.Value, Len(fnd.Value) - Len(Split(fnd.Value, ":")(0)) - 2)
Set fnd = Nothing
Set fnd = rng.Find("Other")
If Not fnd Is Nothing Then wk.Cells(6, j).Value = Split(fnd.Value, ":")(1)
Set fnd = Nothing
i = Cells(i, 1).End(xlDown).row + 1
j = j + 1
Next
End Sub
Demo:
May try something like this. Original code was modified and organized to complete the task intended. It takes cares if the other parameters of the test result are not organised in sequence as shown, blank row in between the parameters, no blank row between test results and or missing parameters. It only considers parameters found between rows of two test titles (date time). Takes only 0.5 seconds to process 200 test results from more than 1 K rows.
Option Explicit
Sub Transpose()
Dim dDate As Date
Dim NumberofTasks As Long
Dim x As Long, LastRow As Long, Xval As Variant
Dim srcWs As Worksheet, trgWs As Worksheet
Dim tm As Double
tm = Timer
Set srcWs = ThisWorkbook.ActiveSheet
Set trgWs = ThisWorkbook.Worksheets.Add
trgWs.Cells(1, 1).Value = "Title"
trgWs.Cells(2, 1).Value = "Ounces:"
trgWs.Cells(3, 1).Value = "Concentration:"
trgWs.Cells(4, 1).Value = "Expiration Date:"
trgWs.Cells(5, 1).Value = "Other:"
With srcWs
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NumberofTasks = 0
x = 1
Do While x <= LastRow
Xval = .Cells(x, 1).Value
If IsDate(Xval) Then
NumberofTasks = NumberofTasks + 1
trgWs.Cells(1, NumberofTasks + 1).Value = .Range("A" & x).Value
ElseIf VarType(Xval) = vbString And NumberofTasks > 0 Then
Xval = Trim(LCase(Xval))
If InStr(1, Xval, "ounces:") > 0 Then
trgWs.Cells(2, NumberofTasks + 1).Value = Trim(Replace(Xval, "ounces:", ""))
ElseIf InStr(1, Xval, "concentration:") > 0 Then
trgWs.Cells(3, NumberofTasks + 1).Value = Trim(Replace(Xval, "concentration:", ""))
ElseIf InStr(1, Xval, "expiration date:") > 0 Then
trgWs.Cells(4, NumberofTasks + 1).Value = Trim(Replace(Xval, "expiration date:", ""))
ElseIf InStr(1, Xval, "other:") > 0 Then
trgWs.Cells(5, NumberofTasks + 1).Value = Trim(Replace(Xval, "other:", ""))
End If
End If
x = x + 1
Loop
End With
'Debug.Print "Seconds "; Timer - tm
End Sub
Tested to produce the result like
this