Related
I have a range with several series of dates and values
Input
Output
And i need this output, a series of dates ( using the min date and max date from input ).
If output date matches with the input date of a series then set the value of this day if not set a 0. I have tried all kind of loops but i have 40 series o dates and values ( 80 columns x 2000 rows ) and i can't get anything fast.
Please, test the next code. You must take care that the format in the analyzed range to be the same as the one in the built range (dd/mm/yyyy). It returns the processed array in another sheet (sh1). I used the next sheet. If it is empty in your case, you can use the code as it is. There must not exist other records in the first row, except the last Valuex. The code can be adapted to search this header type, but it is not the object of the solution:
Sub CentralizeDateValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD + 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from min to max:
arrD1 = Evaluate("TEXT(DATE(" & Year(minD) & "," & month(minD) & ",row(" & Day(minD) & ":" & NoD & ")),""dd/mm/yyyy"")")
Debug.Print Join(Application.Transpose(arrD1), "|") 'just to visually check it.
arrD2 = arrD1 'clone the built dates array
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) + 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col + 1
mtch = Application.match(CStr(arrGen(i, j)), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j + 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2)).Value = arrD2
Sub CentralizeDateLongValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD + 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from long numbers, corespondent to min and max dates:
arrD1 = Evaluate("row(" & CLng(minD) & ":" & CLng(maxD) & ")")
'Debug.Print Join(Application.Transpose(arrD1), "|"): 'Stop
arrD2 = arrD1 ''clone the built dates arary
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) + 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value2: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col + 1
mtch = Application.match(arrGen(i, j), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j + 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
With sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2))
.Value2 = arrD2
.Columns(1).NumberFormat = "dd/mm/yyyy"
End With
'put headers:
Dim arrHd: arrHd = Application.Transpose(Evaluate("row(1:" & UBound(arrD2, 2) - 1 & ")"))
arrHd = Split("Date|Value" & Join(arrHd, "|Value"), "|")
sh1.Range("A1").Resize(1, UBound(arrHd) + 1).Value = arrHd: sh1.Activate
MsgBox "Ready..." & vbCrLf & _
" (" & Format(Timer - StartTime, "00.00") & " seconds)"
End Sub
End Sub
It returns in "A1" of the next sheet the header and in "A2" the processed array.
Please, send some feedback after testing it. I am curious how much it takes for a big range. I tested it on a small range, but solution must run on any range...
Edited:
Please, test the following version. It uses a Long numbers array, corresponding to the necessary Dates range. This allows using value2 to create the global array, which allows a (little) faster iteration and does no need the CStr conversion. Not date format dependent, too:
Sub CentralizeDateLongValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD + 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from long numbers, corespondent to min and max dates:
arrD1 = Evaluate("row(" & CLng(minD) & ":" & CLng(maxD) & ")")
'Debug.Print Join(Application.Transpose(arrD1), "|"): 'Stop
arrD2 = arrD1 ''clone the built dates arary
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) + 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value2: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col + 1
mtch = Application.match(arrGen(i, j), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j + 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
Dim rngBlank As Range
With sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2))
.Value2 = arrD2
.Columns(1).NumberFormat = "dd/mm/yyyy"
.EntireColumn.AutoFit
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.BorderAround Weight:=xlThick
On Error Resume Next 'for the case (even imporbable) that no any blank cell will exist...
Set rngBlank = .SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
End With
If Not rngBlank Is Nothing Then rngBlank.Value = 0
'put headers:
Dim arrHd: arrHd = Application.Transpose(Evaluate("row(1:" & UBound(arrD2, 2) - 1 & ")"))
arrHd = Split("Date|Value" & Join(arrHd, "|Value"), "|")
With sh1.Range("A1").Resize(1, UBound(arrHd) + 1)
.Value = arrHd
.Font.Bold = True
.EntireColumn.AutoFit
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThick
End With
sh1.Activate
MsgBox "Ready..." & vbCrLf & _
" (" & Format(Timer - StartTime, "00.00") & " seconds)"
End Sub
Please, send some feedback after testing it...
I'm new using VBA and I'm trying to code into VBA but it didn't work so far, my timestamp data is not common and I got 10000+ rows to do the same formula (sometime excel just crash so i would like to try VBA)
timestamp that I tried split
Edit : add code
Sub Split_text_3()
Dim p As String
For x = 1 To 6 '---How do it until last cell?
Cells(x, 2).Value = Mid(Cells(x, 1).Value, 9, 2) 'combind in same cell
Cells(x, 3).Value = Mid(Cells(x, 1).Value, 5, 3) 'combind in same cell
Cells(x, 4).Value = Mid(Cells(x, 1).Value, 21, 4) 'combind in same cell
Cells(x, 5).Value = Mid(Cells(x, 1).Value, 12, 8)
Next x End Sub
and the data look like this (I tried to separate it first and then might try to combine them later)
image
Please, try the next function:
Function extractDateTime(strTime As String) As Variant
Dim arrD, d As Date, t As Date
arrD = Split(strTime, " ")
d = CDate(arrD(2) & "/" & arrD(1) & "/" & arrD(4))
t = CDate(arrD(3))
extractDateTime = Array(d, t)
End Function
It can be tested in the next way:
Sub testExtractDate()
Dim x As String, arrDate
x = "WED SEP 08 08:13:52 2021"
arrDate = extractDateTime(x)
Debug.Print arrDate(0), arrDate(1)
End Sub
If it returns as you need (I think, yes...), you can use the next function to process the range. It assumes that the column keeping the strings are A:A, and returns in C:D:
Sub useFunction()
Dim sh As Worksheet, lastR As Long, Arr, arrDate, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
Arr = sh.Range("A2:A" & lastR).Value
If IsArray(Arr) Then
ReDim arrFin(1 To UBound(Arr), 1 To 2)
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
arrDate = extractDateTime(CStr(Arr(i, 1)))
arrFin(i, 1) = arrDate(0): arrFin(i, 2) = arrDate(1)
End If
Next i
sh.Range("C2").Resize(UBound(arrFin), 2).Value = arrFin
Else
sh.Range("C2:D2").Value = extractDateTime(CStr(sh.Range("A2").Value))
End If
End Sub
I think I have another solution (not bulletproof) but it is simplier, quicker and code less solution (no offense FraneDuru!):
Sub DateStamp()
Dim arr, arr_temp, arr_new() As Variant
Dim i As long
'Take cells from selected all the way down to 1st blank cell
'and assign values to an array
arr = ThisWorkbook.ActiveSheet.Range(Selection, Selection.End(xlDown)).Value
ReDim Preserve arr_new(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
'Make another array by spliting input string by whitespace delimiter (default)
arr_temp = Split(arr(i, 1))
'Construct values in desired "format"
arr_new(i, 1) = "'" & arr_temp(2) & "/" & arr_temp(1) & "/" & arr_temp(4)
arr_new(i, 2) = arr_temp(3)
Next i
'Paste result into Excel
Selection.Offset(0, 1).Resize(UBound(arr), 2) = arr_new
End Sub
All you have to do is to select the cell toy want to start with and run the macro! :)
Bellow also a picture with watches, so you can catch-up what is going on:
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
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
I have a table which have various columns, One of which has the Week Number and the other stores a time in hh:mm:ss, I am trying to put both these into an array so I can do a quick comparsion, but I cant work outhow to put them in the array as string so that time would look like "00:10:22" and not its number equivalent 0.3242342342 etc
The week column is dereived from =IFERROR(VALUE([#[DC week]]),"")
and the time column is from =IFERROR(IF(LEFT(P2,1)="-",-TIMEVALUE("00:00"),TIMEVALUE(P2)),"")
This is what I have but the array comes back as double., help please
Dim maxtime As String
Dim tblLastRow As Integer
Dim Arr As Variant
Dim uniquesArray As Variant
Dim lastRow As Long
With Sheets("Raw2")
tblLastRow = .Cells(.Rows.Count, "A").End(xlUp).row
.Columns("X:X").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AE1"), Unique:=True
lastRow = .Cells(.Rows.Count, "AE").End(xlUp).row
uniquesArray = .Range("AE2:AE" & lastRow)
.Columns("AE").ClearContents
.Columns("X:Y").Copy
.Columns("AE").PasteSpecial xlValues
Arr = .Range("AE2:AF" & tblLastRow)
End With
Sheet20.Columns("A:B").ClearContents
Sheet20.Cells(1, 1) = "Week"
Sheet20.Cells(1, 2) = "Time To Abandon"
For a = 1 To UBound(uniquesArray)
maxtime = ""
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = uniquesArray(a, 1) Then
If Arr(i, 2) > maxtime Then maxtime = Arr(i, 2)
End If
Next i
Sheet20.Cells(a + 1, 1) = uniquesArray(a, 1)
Sheet20.Cells(a + 1, 2) = maxtime
Next a
Thanks YoeE3k, yes the columns are formatted how I want, I tried Arr = .Range("AE2:AF" & tblLastRow).Text but that returned a null array! but with using Format(Arr(i, 2), "hh:mm:ss") that worked and because of that I dont need to copy the columns I can just reference the original columns.
Dim maxtime As String
Dim tblLastRow As Integer
Dim Arr As Variant
Dim uniquesArray As Variant
Dim lastRow As Long
With Sheets("Raw2")
tblLastRow = .Cells(.Rows.Count, "A").End(xlUp).row
.Columns("X:X").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AE1"), Unique:=True
lastRow = .Cells(.Rows.Count, "AE").End(xlUp).row
uniquesArray = .Range("AE2:AE" & lastRow)
.Columns("AE").ClearContents
Arr = .Range("X2:Y" & tblLastRow)
End With
Sheet20.Columns("A:B").ClearContents
Sheet20.Cells(1, 1) = "Week"
Sheet20.Cells(1, 2) = "Max Time To Abandon"
For a = 1 To UBound(uniquesArray)
maxtime = ""
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = uniquesArray(a, 1) Then
If Format(Arr(i, 2), "hh:mm:ss") > maxtime Then maxtime = Format(Arr(i, 2), "hh:mm:ss")
End If
Next i
Sheet20.Cells(a + 1, 1) = uniquesArray(a, 1)
Sheet20.Cells(a + 1, 2) = maxtime
Next a