Kindly see below code where it takes too much time run for more than 30rows in a range. (its similar to knapsack algorithm requirements)
let me try to explain below in detail,
Input Base sheet: Column A having values (For ex: 1555),
Column B having its Assignment value (A1),
Column C & D its filter value which will perform against input data sheet file.
Program working concept:
it takes first row(2) data from base sheet and apply filter (C2 & D2 value) in input data sheet (Column A & B respectively) then it checks value in column C and it find best sum to match the value (1555) or nearest to it and after it assigns value (which is A1) against those rows and repeats the same for next rows.
I have posted image below.
Kindly refer for Input Base sheet and Input Data sheet and
copy the codes in another workbook.
Run the macro, Choose Base sheet and the Data sheet. Program would run and assigns in Input data sheet. It runs super fast in lesser rows when I have more rows it gets hang/takes too hours to run.
Help me to where it can be speed up.
Appreciate your supports.
Thanks
input base sheet
input data sheet:
Sub sample1()
Dim lrow As Integer
Dim frow As Integer
Dim row As Integer
Dim ar As Variant
Dim aar As Variant
Dim Sol(), csol()
Dim arr As Variant
Dim pos As Integer
Dim arow() As Integer
Dim rng As Range
Dim rn As Range
Dim r As Range
Dim k As Integer
Dim itr As Integer
Dim path As String
Dim tm_base As Workbook
Dim tm_data As Workbook
Dim sh_base As Worksheet
Dim sh_data As Worksheet
Dim sh As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sh = ActiveSheet
ReDim arr(0)
arr(0) = ""
path = FileSelection("Input Base")
If path = "" Then Exit Sub
Set tm_base = Workbooks.Open(path)
path = FileSelection("Input Data")
If path = "" Then Exit Sub
Set tm_data = Workbooks.Open(path)
Set sh_base = tm_base.ActiveSheet
Set sh_data = tm_data.ActiveSheet
lrow = sh_data.Cells(Rows.Count, "A").End(xlUp).row
frow = sh_base.Cells(Rows.Count, "A").End(xlUp).row
SortMacro ActiveSheet, sh_base.Range("A2:A" & frow), sh_base.Range("A1:G" & frow), 2
SortMacro ActiveSheet, sh_data.Range("C2:C" & lrow), sh_data.Range("A1:G" & lrow), 2
For row = 2 To frow
If sh_base.Cells(row, "H") <> "Done" Then
itr = 1
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
op2:
sh_data.Range("A1:G" & lrow).AutoFilter Field:=1, Criteria1:=sh_base.Cells(row, "C").Value
sh_data.Range("A1:G" & lrow).AutoFilter Field:=2, Criteria1:=sh_base.Cells(row, "D").Value
Set rn = Nothing
On Error Resume Next
Set rn = sh_data.Range("C2:C" & lrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rn Is Nothing Then
ReDim ar(0)
ReDim arow(0)
k = 1
For Each r In rn
ReDim Preserve arow(k)
ReDim Preserve ar(k)
ar(k) = r.Value
arow(k) = r.row
k = k + 1
Next
ReDim Sol(LBound(ar) To UBound(ar))
ReDim csol(LBound(ar) To UBound(ar))
limsum = sh_base.Cells(row, "A").Value
For i = LBound(ar) To UBound(ar)
If ar(i) > limsum Then
ar(i) = -1
End If
Next
maxsum = 0
findsum ar, Sol, csol, maxsum, limsum, UBound(ar), UBound(ar)
ss = ""
For i = 1 To Sol(0)
'ss = ss & sep & ar(sol(i))
'sep = ","
If Not arr(UBound(arr)) = "" Then
ReDim Preserve arr(UBound(arr) + 1)
End If
arr(UBound(arr)) = ar(Sol(i))
Next i
'MsgBox ss & " sum =" & maxsum
For j = LBound(arr) To UBound(arr)
pos = Application.Match(arr(j), ar, False)
If ar(pos - 1) > 0 Then
ar(pos - 1) = -1
End If
pos = arow(pos - 1)
If sh.Range("B1") = "Option 01" Then
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value
Else
sh_data.Cells(pos, "D") = sh_base.Cells(row, "B").Value & " " & Format(itr, "00")
End If
Next
ReDim arr(0)
arr(0) = ""
sh_base.Cells(row, "H") = "Done"
If sh.Range("B1") = "Option 02" Then
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4, Criteria1:="="
Set rng = sh_data.Range("A1:A" & lrow).SpecialCells(xlCellTypeVisible)
If rng.Cells.Count > 1 Then
itr = itr + 1
GoTo op2
End If
End If
End If
sh_data.Range("A1:G" & frow).AutoFilter Field:=1
sh_data.Range("A1:G" & frow).AutoFilter Field:=2
sh_data.Range("A1:G" & lrow).AutoFilter Field:=4
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub findsum(ByVal a, ByRef Sol, ByRef csol, ByRef maxsum, ByRef limsum, si, maxcount, Optional s = 0, Optional lvl = 1, Optional dif = 100000, Optional minuscount = 0, Optional tsol, Optional j = 0)
' recursive sub
For i = LBound(a) To si
If a(i) > 0 Then
If s + a(i) > limsum Then findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
s = s + a(i)
csol(lvl) = i
If s <= limsum Then
If s > maxsum Then ' we found a sum greater than current max we save it
maxsum = s
Sol(0) = lvl
For j = 1 To lvl
Sol(j) = csol(j)
Next j
End If
If i > LBound(a) Then ' pick another number
findsum a, Sol, csol, maxsum, limsum, i - 1, maxcount, s, lvl + 1, dif, minuscount, tsol
End If
End If
s = s - a(i)
If maxsum = limsum Then Exit For 'exit if exact match
End If
Next i
End Sub
Sub SortMacro(ws As Worksheet, rn As Range, rng As Range, ord As Integer)
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=rn, _
SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
With ws.Sort
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Function FileSelection(file As String)
Dim path As String
Dim st As String
Dim i As Integer
Dim j As Integer
FileSelection = ""
With Application.FileDialog(3)
.title = "Select the " & file & " file"
.AllowMultiSelect = False
.InitialFileName = st
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You didn't select the file!", vbExclamation, "Canceled"
Exit Function
Else
FileSelection = .SelectedItems(1)
End If
End With
End Function
You can't. I ran it. With 20 base data points and 100 data points you already have sub findsum called 79 million times. It's a combinatorial explosion and no amount of code tweaking will fix that. You'll have to find a better algorithm.
The following code successfully executes for small data sets:
Option Explicit
Option Base 1
Sub Left()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws1, _
ws2 As Worksheet, _
wb As Workbook
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Adj")
Set ws2 = wb.Worksheets("Deleted")
Dim a, _
b, _
i, _
j, _
k As Long
a = 957
b = 290150
Dim Item1, _
Item2, _
Arr() As Variant
With ws2
For i = 2 To a
.Cells(i, 6) = Left(.Cells(i, 1), 11)
.Cells(i, 7) = Right(.Cells(i, 1), 4)
Next i
End With
With ws1
For j = 2 To b
ReDim Preserve Arr(j - 1)
Item1 = Chr(34) & .Cells(j, 7) & Chr(34)
Item2 = Chr(34) & .Cells(j, 9) & Chr(34)
On Error Resume Next
k = Evaluate("=MATCH(1,('Deleted'!F:F = " & Item1 & ")*('Deleted'!G:G = " & Item2 & "),0)")
If Err.Number = 13 Then
Arr(j - 1) = ""
Else: Arr(j - 1) = k
End If
On Error GoTo 0
Next j
.Range(.Cells(2, 15), .Cells(b, 15)) = WorksheetFunction.Transpose(Arr())
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
However, for large data sets - such as 290,150 rows - the macro spins its wheels. It's known that Evaluate is expensive to run and I have tried running for sample sizes of 30 (success) and 1,000 (unsuccessful) and debugged carefully. Obviously in-cell array formulation drag-and-drop is not a practical alternative. So, the problem reduces to resolving endless spinning for the given multiple criteria match function required.
How do I bypass this constraint?
Try this approach using a dictionary as a lookup:
Sub Left()
Dim wsAdj As Worksheet, wsDel As Worksheet, wb As Workbook
Dim lrDel As Long, lrAdj As Long, r As Long
Dim dict, t, arr, arrG, arrI, arrRes, k
Set wb = ThisWorkbook
Set wsAdj = wb.Worksheets("Adj")
Set wsDel = wb.Worksheets("Deleted")
lrAdj = 290150
lrDel = 957
t = Timer
'load a dictionary with lookup values constructed from wsDel ColA
Set dict = CreateObject("scripting.dictionary")
arr = wsDel.Range("A2:A" & lrDel).Value
For r = 1 To UBound(arr, 1)
k = Left(arr(r, 1), 11) & Chr(0) & Right(arr(r, 1), 4)
dict(k) = r + 1 '+1 to adjust for starting at row 2
Next r
arrG = wsAdj.Range("G2:G" & lrAdj).Value 'get the match columns as arrays
arrI = wsAdj.Range("I2:I" & lrAdj).Value
ReDim arrRes(1 To UBound(arrG, 1), 1 To 1) 'resize the "result" array
'loop the values from wsAdj
For r = 1 To UBound(arrG, 1)
k = arrG(r, 1) & Chr(0) & arrI(r, 1) 'build the "key"
If dict.exists(k) Then
arrRes(r, 1) = dict(k) 'get the matched row
End If
Next r
wsAdj.Cells(2, 15).Resize(UBound(arrRes, 1), 1).Value = arrRes 'put the array on the sheet
Debug.Print "done", Timer - t ' <1 sec
End Sub
Stating Ranges instead of Columns and removing ReDim on loop helped.
I have an obstacle to automatically retrieve the data that are unique from the New Info that are the not available inside the Masterlist and add into the Masterlist on a routine basis.
Are there any ways to setup formulas or macros to identify the list in the Masterlist that are not available in the New Info worksheet?
Above would be the Ideal Result
Feeling generous so i'll try help and hope you can follow along. if you need to know how to add module to VBA, i've added this at the bottom.
I have functions i've created which do various things so that you only need to write a few lines of code to accomplish the task. top section is the code and the bottom section are the functions which allow this task to be so easy!
the idea is:
You 'Extract' the data
You 'Transform' the data
You 'Load' the Data back to the spreadsheet
The code would look something like this:
'https://www.linkedin.com/in/syed-n-928b2490/
Option Base 1
Sub WorkWithData()
Dim dataArray1() As Variant ' empty array for data
Dim dataArray2() As Variant ' empty array for data
Dim combinedArray() As Variant ' empty array for data
'First Get the data from both sheets and combine the data sets together - note the columns must be same
dataArray1() = GetArr("MasterList")
dataArray2() = GetArr("New Info")
'dataArray2() = GetArr("New Info",,,,,"C:/users/documents/bob.xlsx") ' if you want to obtain data directly from an external workbook you can use this line instead
'join the two datas together and remove dupes
combinedArray() = UnionArr(dataArray1(), dataArray2(), , True)
'Specify the sheet you want to paste the data in
PasteArr "MasterList", combinedArray()
Erase combinedArray
Erase dataArray1
Erase dataArray2
End Sub
''''''''''''''''''''''''''''''''''''''''''''''
' General Functions
' created by: Syed Noshahi
' linked in: https://www.linkedin.com/in/syed-n-928b2490/
''''''''''''''''''''''''''''''''''''''''''''''
'------- ---------------------- ---------
'------- Get Data into an Array ---------
'------- ---------------------- ---------
Function GetArr(SheetName As String, Optional ColumnForSize As Long = 1, Optional RowForSize As Long = 1, Optional Rowstart As Long = 1, Optional ColStart As Long = 1, Optional sExternalWBFullName As String = "", Optional bLeaveFileOpen As Boolean = False, Optional lSpecifyRows As Long = 0, Optional lSpecifyCols As Long = 0) As Variant()
Dim vArray() As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
On Error GoTo ErrH
If Len(sExternalWBFullName) > 0 Then
i = Len(sExternalWBFullName)
Do
i = i - 1
s = Mid(sExternalWBFullName, i, 1)
Loop Until s = "\" Or (i = 1)
If i <> 0 Then
sWBName = Right(sExternalWBFullName, Len(sExternalWBFullName) - i)
sWBPath = Replace(sExternalWBFullName, sWBName, "", , , 1)
For Each wbs In Application.Workbooks
If wbs.Name = sWBName Then
sWBPath = ""
Exit For
End If
Next
End If
End If
If Len(sWBPath) > 0 And Len(sWBName) > 0 Then
Set wb = Workbooks.Open(sExternalWBFullName, False, True)
ElseIf Len(sWBName) > 0 Then
Set wb = Workbooks(sWBName)
End If: Set ws = wb.Sheets(SheetName): On Error GoTo 0
With ws
If .FilterMode = True Then .ShowAllData
If lSpecifyRows > 0 Then
lRow = lSpecifyRows
Else
lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).Row - Rowstart + 1
End If
If lSpecifyCols > 0 Then
lCol = lSpecifyCols
Else
lCol = .Cells(RowForSize, .Columns.Count).End(xlToLeft).Column
End If
If lRow > 1 Or lCol > 1 Then
vArray() = .Cells(Rowstart, ColStart).Resize(lRow, lCol).Value2
GetArr = vArray()
End If
End With
If Len(sWBName) > 0 And Not bLeaveFileOpen Then
wb.Close False
End If
EndFunction:
Exit Function
ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction
End Function
'------- -------------------- ---------
'------- Paste Array to Sheet ---------
'------- -------------------- ---------
Function PasteArr(SheetName As String, vArray() As Variant, Optional ColumnForSize As Long = 1, Optional bClearContents As Boolean = True, Optional bLastRow As Boolean, Optional bOmitFirstRow As Boolean, Optional sWBName As String = "", Optional lPasteCol As Long = 1, Optional lStartRow As Long = 1)
Dim ws As Worksheet
Set wb = ThisWorkbook
On Error GoTo ErrH
If Len(sWBName) > 0 Then Set wb = Workbooks(sWBName)
Set ws = ThisWorkbook.Sheets(SheetName): On Error GoTo 0
x = 0
With ws
If .FilterMode = True Then .ShowAllData
If bClearContents Then
If lPasteCol > 1 And ColumnForSize = 1 Then ColumnForSize = lPasteCol
lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).Row
If lRow > 1 And Len(.Cells(lStartRow, lPasteCol)) > 0 Then .Cells(lStartRow, lPasteCol).Resize(lRow - lStartRow + 1, UBound(vArray, 2)).ClearContents
End If
If bOmitFirstRow Then
For i = LBound(vArray, 2) To UBound(vArray, 2)
vArray(LBound(vArray), i) = vArray(UBound(vArray), i)
vArray(UBound(vArray), i) = ""
Next
x = 1
End If
If Not (Not vArray()) Then
If bLastRow Then
If lPasteCol > 1 And ColumnForSize = 1 Then ColumnForSize = lPasteCol
lRow = .Cells(.Rows.Count, ColumnForSize).End(xlUp).Row + 1
.Cells(lRow, lPasteCol).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
Else
.Cells(lStartRow, lPasteCol).Resize(UBound(vArray) - x, UBound(vArray, 2)) = vArray()
End If
End If
End With
EndFunction:
Exit Function
ErrH:
Debug.Print "Worksheet name '" & SheetName & "' not found."
Resume EndFunction
End Function
'------- -------------- ------
'------- Union an Array ------
'------- -------------- ------
Function UnionArr(arrTemp1(), arrTemp2(), Optional RemoveColumns As Boolean = True, Optional RemoveDuplicates As Boolean = False)
' Function requires two arrays of same column size. First array dictates the size
Dim k As Long
Dim r As Long
Dim vTempArr()
Dim vArray(): Dim vHoldingArray(1 To 1)
Dim Od1 As Object: Set Od1 = CreateObject("Scripting.Dictionary"): Od1.CompareMode = 1
If RemoveColumns Then
k = 1
m = 2
Else
k = 0
m = 1
End If
r = UBound(arrTemp1) + UBound(arrTemp2) - k
ReDim vArray(r, UBound(arrTemp1, 2))
For i = 1 To UBound(arrTemp1)
For j = 1 To UBound(arrTemp1, 2)
vArray(i, j) = arrTemp1(i, j)
Next
Next
i = i - 1
For l = m To UBound(arrTemp2)
For j = 1 To UBound(arrTemp2, 2)
vArray(i + l - k, j) = arrTemp2(l, j)
Next
Next
'if removing duplicates has been selected we remove where the entire Row is a dupe
If RemoveDuplicates Then
k = 1
' first get all the columns together and store in a dictionary
For i = 2 To UBound(vArray)
vHoldingArray(1) = ""
For j = 1 To UBound(vArray, 2)
vHoldingArray(1) = vHoldingArray(1) & vArray(i, j)
Next
If Not Od1.Exists(vHoldingArray(1) & "key") Then
k = k + 1
Od1(vHoldingArray(1) & "key") = 1
End If
Next
ReDim vTempArr(k, UBound(vArray, 2))
k = 1
Od1.RemoveAll
For i = 1 To UBound(vArray, 2)
vTempArr(k, i) = vArray(k, i)
Next
For i = 2 To UBound(vArray)
vHoldingArray(1) = ""
For j = 1 To UBound(vArray, 2)
vHoldingArray(1) = vHoldingArray(1) & vArray(i, j)
Next
If Not Od1.Exists(vHoldingArray(1) & "key") Then
Od1(vHoldingArray(1) & "key") = 1
k = k + 1
For j = 1 To UBound(vArray, 2)
vTempArr(k, j) = vArray(i, j)
Next
End If
Next
vArray() = vTempArr()
End If
UnionArr = vArray()
Erase vTempArr()
Erase vArray()
Set Od1 = Nothing
End Function
on Excel press Alt + F11 (opens VBA editor)
view --> Project explorer
on the top left hand side click your file name (in the project window)
insert --> module
i am not be able to make this computation efficiently with excel (vba):
Input
Output
Doing this with tables is incredible slow, when you have a few rows and columns is working perfectly, but is no practical when you increase the number of series and rows.
What i do is update Output Table with VBA, steps:
Delete data of Output Listobject Table
Resize Listobject Range with number of dates between (min max Dates1, Dates,2)
Generate Dates and dump it in the Output Listobject Table Dates column.
I get the matching with this formula array formula in each Result row in the output listobject table:
=SUM(IF((DAY(T_1[Date])=DAY([#Date]))*(MONTH(T_1[Date])=MONTH([#Date]))*(YEAR(T_1[Date])=AÑO([#Date]));T_1[Result1]))
The Number of Series is dinamic and rows will be dynamic, i have up to 30 columns and 5000 rows. Could you give me some example or approach to achieve this more efficiently?
Here is a table with time execution speed of participants snippets. Tested with the whole data. 3161 rows x 40 columns (20 Results columns to match):
Execution time table
The following does not list the dates in order, but collects data for each input date. It is similar to the pivot table.
Compare the execution speed with other code.
Sub MergeData()
Dim strU As String
Dim myWs As Worksheet, Ws As Worksheet
Dim vTable() As Variant
Dim vFid1(), vFid2()
Dim k As Integer, n As Integer, c As Integer
Dim sWsName As String, s As String
Dim strSQL As String
Set myWs = Sheets(1) '<~~ Your data Sheet
Set Ws = Sheets(2) '<~~ Result Sheet
sWsName = myWs.Name & "$"
With myWs
c = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To c Step 2
n = n + 1
ReDim Preserve vTable(1 To n)
ReDim Preserve vFid1(1 To n)
ReDim Preserve vFid2(1 To n)
vTable(n) = sWsName & .Cells(1, i).Resize(65536, 2).Address(0, 0)
vFid1(n) = "[" & .Cells(1, i) & "]"
vFid2(n) = "[" & .Cells(1, i + 1) & "]"
Next i
End With
For k = 1 To n - 1
s = Replace(vFid2(k), "[", "")
s = Replace(s, "]", "")
strU = strU & "SELECT " & vFid1(k) & " as Dates ," & vFid2(k) & " as Result , '" & s & "' as myPivot " & " FROM [" & vTable(k) & "] where not isnull(" & vFid1(k) & ") union All "
Next k
s = Replace(vFid2(n), "[", "")
s = Replace(s, "]", "")
strU = strU & "SELECT " & vFid1(n) & " as Dates," & vFid2(n) & " as Result, '" & s & "' as myPivot " & " FROM [" & vTable(n) & "] where not isnull(" & vFid1(n) & ") "
strSQL = "TRANSFORM MAX(Result) "
strSQL = strSQL & "SELECT Dates FROM "
strSQL = strSQL & "(" & strU & ") "
strSQL = strSQL & "GROUP BY Dates "
strSQL = strSQL & "ORDER BY Dates "
strSQL = strSQL & "PIVOT myPivot "
exeSQL Ws, strSQL
Ws.Range("a1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = 0
End Sub
Sub exeSQL(Ws As Worksheet, strSQL As String)
Dim Rs As Object
Dim strConn As String
Dim i As Integer
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 12.0;"
Set Rs = CreateObject("ADODB.Recordset")
Rs.Open strSQL, strConn
If Not Rs.EOF Then
With Ws
.Range("a1").CurrentRegion.ClearContents
For i = 0 To Rs.Fields.Count - 1
.Cells(1, i + 1).Value = Rs.Fields(i).Name
Next
.Range("a" & 2).CopyFromRecordset Rs
End With
End If
Rs.Close
Set Rs = Nothing
End Sub
Data image
you can extend over 30 series. This is only 5 series.
Result image
First, I have made the assumption that you have dates and results in adjacent columns in the form of Dates N | Results N, image below.
Second, I have written the below code which should solve your problem. Note: this is not completely scalable as is, but you can use this now to progress further and modify to your needs. Also, please excuse my poor maths to calculate the out_col_num variable.
Option Explicit
Sub Merge_Dates()
'variables to set up dates
Dim lYear As Long: lYear = 2020
Dim lMonth As Long: lMonth = 3
Dim lDay As Long
'arrays
Dim arr_in() As Variant
Dim arr_out() As Variant
Dim x_in As Long, y_in As Long
Dim x_out As Long, y_out As Long
Dim out_col_num As Long, n As Long: n = 1
arr_in = ActiveSheet.UsedRange.Value
'we need to define the bounds for the output array
'this will contain all dates for March (in this example)
'also hold the results in the columns - this is a function on lbound(2)
ReDim arr_out(1 To 32, 1 To (UBound(arr_in, 2) - 1))
'header for out array
arr_out(1, 1) = "Dates"
'load dates
For lDay = 1 To 31
arr_out(lDay + 1, 1) = CDate(Format(DateSerial(lYear, lMonth, lDay), "DD/MM/YYYY"))
Next lDay
'set column headers
For x_out = LBound(arr_out, 2) + 1 To UBound(arr_out, 2)
arr_out(1, x_out) = "Results" & (x_out - 1)
Next x_out
'now loop through in array and map to out array
'you can do this multiple ways, below is just one
'loop x dim in array
For x_in = LBound(arr_in, 2) To UBound(arr_in, 2) Step 2
'loop y dim in array
For y_in = LBound(arr_in, 1) + 1 To UBound(arr_in, 1)
'loop y dim out array to store result
For y_out = LBound(arr_out, 1) + 1 To UBound(arr_out, 1)
If arr_out(y_out, 1) = arr_in(y_in, x_in) Then
'out column is a function of in column
'-n + 3n
out_col_num = (-1 * x_in) + (3 * n)
arr_out(y_out, out_col_num) = arr_in(y_in, x_in + 1)
Exit For
End If
Next y_out
Next y_in
'increment n
n = n + 1
Next x_in
'output
ActiveSheet.Range("A10").Resize(UBound(arr_out, 1), UBound(arr_out, 2)).Value = arr_out
End Sub
So given the example, assuming your dates cover only March 2020 (something you will have to modify to build it more scalable):
Will give the output as below:
I've put something together using ADODB Recordsets, so that I can use .Filter and .Find. This code outputs the unique dates, and then the result on that date for each result set.
Const AD_DATE = 7
Const AD_VARIANT = 12
Const AD_BIGINT = 20
Const AD_VARCHAR = 200
Const AD_FILTERNONE = 0
Sub sResultData()
On Error GoTo E_Handle
Dim aResultSet() As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim lngLoopRow As Long
Dim lngLoopCol As Long
Dim rsMaster As Object
Dim rsDate As Object
Set rsMaster = CreateObject("ADODB.Recordset")
Set rsDate = CreateObject("ADODB.Recordset")
lngMaxRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
lngMaxCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
With rsMaster.Fields
.Append "ResultDate", AD_DATE
.Append "ResultSet", AD_VARCHAR, 50
.Append "ResultData", AD_BIGINT
End With
With rsDate.Fields
.Append "ResultDate", AD_DATE
End With
rsMaster.Open
rsDate.Open
ReDim aResultSet(1 To lngMaxCol / 2)
For lngLoopCol = 2 To lngMaxCol Step 2
aResultSet(lngLoopCol / 2) = ActiveSheet.Cells(1, lngLoopCol)
Next lngLoopCol
For lngLoopRow = 2 To lngMaxRow
For lngLoopCol = 2 To lngMaxCol Step 2
With rsMaster
.AddNew
!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
!ResultSet = ActiveSheet.Cells(1, lngLoopCol)
!ResultData = ActiveSheet.Cells(lngLoopRow, lngLoopCol)
.Update
End With
If (rsDate.BOF And rsDate.EOF) Then ' dealing with first record, so cannot do .Find
rsDate.AddNew
rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
rsDate.Update
Else
rsDate.MoveFirst
rsDate.Find "ResultDate=" & Format(ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1), "dd/mmm/yyyy")
If (rsDate.EOF) Or (rsDate.EOF) Then
rsDate.AddNew
rsDate!ResultDate = ActiveSheet.Cells(lngLoopRow, lngLoopCol - 1)
rsDate.Update
End If
End If
Next lngLoopCol
Next lngLoopRow
rsDate.Sort = "ResultDate ASC"
rsDate.MoveFirst
rsMaster.Sort = "ResultSet ASC, ResultDate ASC"
For lngLoopCol = 1 To UBound(aResultSet)
lngLoopRow = lngMaxRow + 5
ActiveSheet.Cells(lngLoopRow - 1, lngLoopCol + 1) = aResultSet(lngLoopCol)
rsMaster.Filter = AD_FILTERNONE
rsMaster.Filter = "ResultSet='" & aResultSet(lngLoopCol) & "'"
rsDate.MoveFirst
Do
ActiveSheet.Cells(lngLoopRow, 1) = rsDate!ResultDate
rsMaster.MoveFirst
rsMaster.Find "ResultDate=#" & Format(rsDate!ResultDate, "dd-mmm-yy") & "#"
If Not rsMaster.EOF Then
ActiveSheet.Cells(lngLoopRow, lngLoopCol + 1) = rsMaster!ResultData
End If
lngLoopRow = lngLoopRow + 1
rsDate.MoveNext
Loop Until rsDate.EOF
Next lngLoopCol
sExit:
On Error Resume Next
rsDate.Close
rsMaster.Close
Set rsDate = Nothing
Set rsMaster = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sResultData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
Test the next code, please. It will deal with as many (pairs of) columns you will have. It determines the minimum, respectively, maximum used date and iterates between the determined interval, collecting data in arrFin array. You can also use any Date interval. The interval will be automatically determined. My code drops the values one column after the existing range. This is done only for testing reasons. I have to test it in a way... You can drop them wherever you need. So, if you intend to run the code for the second time, you must delete the previously returned values.
Sub testMatchReArrange()
Dim sh As Worksheet, arrD As Variant, DateRng As Range, lastCol As Long, lastRow As Long
Dim i As Long, dateStart As Date, dateFinish As Date, dDiff As Long, arrFin As Variant
Dim boolFound As Boolean, checkDate As Date, j As Long, k As Long, f As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column
arrD = sh.Range(sh.Cells(2, 1), Cells(lastRow, lastCol)).value 'array to be processed
'create the specific range keeping only Date, in order to determine the correct date interval. Especially the minimum date...
For i = 1 To lastCol Step 2
If DateRng Is Nothing Then
Set DateRng = sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i))
Else
Set DateRng = Union(DateRng, sh.Range(sh.Cells(2, i), sh.Cells(lastRow, i)))
End If
Next i
dateStart = WorksheetFunction.Min(DateRng) 'starting date
dateFinish = WorksheetFunction.Max(DateRng) 'finishing date
dDiff = dateFinish - dateStart 'the date interval to be processed
'Properly dimension the array to collect the processing result:
ReDim arrFin(1 To dDiff + 2, 1 To lastCol / 2 + 1): f = 1
'Load the head of columns:
arrFin(1, 1) = "Dates"
For i = 2 To lastCol / 2 + 1
arrFin(1, i) = "result" & i - 1
Next i
f = 2 're-initializing the row of for real processed data
checkDate = dateStart 'initialize the date to be used for processing
For i = 1 To dDiff + 1 'for each date in the processed date interval
For j = 1 To UBound(arrD, 1) 'for each row in the processed array
For k = 1 To UBound(arrD, 2) Step 2 'for each column in the processed array (but looking only in add columns)
If CDate(arrD(j, k)) = checkDate Then
arrFin(f, 1) = checkDate: arrFin(f, (k + 1) / 2 + 1) = arrD(j, k + 1)
boolFound = True 'confirming that at least a match exist
End If
Next k
Next j
If Not boolFound Then arrFin(f, 1) = checkDate' Record the date in case of no any match
boolFound = False: f = f + 1
checkDate = checkDate + 1
Next i
'you can use here any other location (sheet, range) to drop the resulted array:
sh.Cells(1, lastCol + 2).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub
In case of a big range, it needs some time, but working only in memory (using arrays) it is the maximum possible speed for such a task.
The code below allows you to specify the columns from which to collect the data and outputs the result on a dedicated sheet which would need to be inserted for that purpose. I called it "Output" but you can pick a name that suits you better. Your original data will not be touched.
Sub MergeDataByDate()
' 006
' define the origin of your data
Const FirstDataRow As Long = 2 ' applicable to both data sets
' set the columns to what they are on your sheet (A = 1, B = 2 etc)
Const C1 As Long = 2 ' Date 1 column
Const Cr1 As Long = 3 ' Result 1 column
Const C2 As Long = 8 ' Date 2 column
Const Cr2 As Long = 11 ' Result 2 column
Dim WsOut As Worksheet ' worksheet for output
Dim ArrIn As Variant ' for input
Dim Arr() As Variant ' for output
Dim Dat As Date ' date counter
Dim Rng As Range
Dim i As Long ' Arr index
Dim R As Long ' row counter
Set WsOut = Worksheets("Output") ' the output sheet must exist: rename to suit
With Worksheets("Input") ' use your tab's name
Set Rng = .Range(.Cells(FirstDataRow, 1), _
.Cells(.Rows.Count, C1).End(xlUp) _
.Offset(0, Cr2 - C1))
ArrIn = Rng.Value
ReDim Arr(1 To 3, (2 * UBound(ArrIn)))
For R = 1 To UBound(ArrIn)
Arr(1, i) = ArrIn(R, C1)
Arr(2, i) = ArrIn(R, Cr1)
Arr(1, i + 1) = ArrIn(R, C2)
Arr(3, i + 1) = ArrIn(R, Cr2)
i = i + 2
Next R
End With
Application.ScreenUpdating = False
With WsOut
Set Rng = .Cells(2, 1).Resize(UBound(Arr, 2), UBound(Arr))
Rng.Value = Application.Transpose(Arr)
With .Sort
With .SortFields
.Clear
.Add Key:=Rng.Cells(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Arr = Rng.Value
For R = (UBound(Arr) - 1) To 1 Step -1
If Arr(R + 1, 1) = Arr(R, 1) Then
Arr(R, 2) = Arr(R, 2) + Arr(R + 1, 2)
Arr(R, 3) = Arr(R, 3) + Arr(R + 1, 3)
For i = 1 To 3
Arr(R + 1, i) = vbNullString
Next i
Else
Arr(R, 2) = Val(Arr(R, 2)) + 0
Arr(R, 3) = Val(Arr(R, 3)) + 0
End If
Next R
Rng.Value = Arr
With WsOut ' sort blanks to the bottom
With .Sort
With .SortFields
.Clear
.Add Key:=Rng.Cells(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
R = .Cells(.Rows.Count, 1).End(xlUp).Row
Dat = CLng(Cells(R, 1).Value)
For R = R To 3 Step -1
Dat = Dat - 1
Do Until .Cells(R - 1, 1).Value = Dat
.Rows(R).Insert
.Cells(R, 1).Value = Dat
.Cells(R, 2).Value = 0
.Cells(R, 3).Value = 0
Dat = Dat - 1
Loop
Next R
End With
Application.ScreenUpdating = True
End Sub
The code first combines the existing data to a single list, then sorts the list by date. It then unites data from the same days into single lines, deleting the lines that become redundant and sort them to the end of the list where they disappear.
In the last step the remaining data are checked for dates and missing dates are inserted between the last first date in the list and the last. If you are particular about those dates, for example, you want them to be the first and last days of a month it's the most efficient to add those two days with zero results anywhere in the original data. If results for those dates exist the zero values will be discarded. If they don't they, and any intervening days, will be added to the output.
Took me a while, but here is my code:
Sub SubOutput()
'Declarations.
Dim WksInput As Worksheet
Dim WksOutput As Worksheet
Dim RngInputFirstCell As Range
Dim RngOutputFirstCell As Range
Dim BytOffset As Byte
Dim RngRange01 As Range
Dim RngTarget As Range
Dim BytWholeCalendar As Byte
Dim DatFirstDate As Date
Dim DatLastDate As Date
Dim IntCounter01 As Integer
'Setting variables.
Set WksInput = Sheets("Input") 'put here the name of the worksheet with input data
Set WksOutput = Sheets("Output") 'put here the name of the worksheet with the output data
Set RngInputFirstCell = WksInput.Range("A1") 'put here the top left cell of the input data (the one with value Dates1)
Set RngOutputFirstCell = WksOutput.Range("A1") 'put here the top left cell of the output data (the one with value Dates)
'Asking what days are to be reported.
BytWholeCalendar = MsgBox("Do you need the output to report data for every day?", vbYesNoCancel, "Report every day?")
'In case of no answer, the subroutine is terminated.
If BytWholeCalendar <> 6 And BytWholeCalendar <> 7 Then
Exit Sub
End If
'Typing "Dates" in RngOutputFirstCell.
RngOutputFirstCell = "Dates"
'Covering the entire input.
Do Until RngInputFirstCell.Offset(0, BytOffset * 2) = ""
'Setting first part of the range to be copied (dates).
Set RngRange01 = WksInput.Range(RngInputFirstCell.Offset(1, BytOffset * 2), WksInput.Cells(WksInput.Rows.Count, RngInputFirstCell.column + BytOffset * 2).End(xlUp))
'Setting the range where to paste the dates.
Set RngTarget = WksOutput.Cells(WksOutput.Rows.Count, RngOutputFirstCell.column).End(xlUp).Offset(1, 0)
Set RngTarget = RngTarget.Resize(RngRange01.Rows.Count)
'Pasting the dates.
RngTarget.Value = RngRange01.Value
'Copying the result name.
RngOutputFirstCell.Offset(0, BytOffset + 1).Value = RngInputFirstCell.Offset(0, BytOffset * 2 + 1).Value
'Setting BytOffset to cover the next rows of data.
BytOffset = BytOffset + 1
Loop
'Editing the dates according to BytWholeCalendar.
Select Case BytWholeCalendar
Case Is = 6
'Setting variables.
DatFirstDate = Excel.WorksheetFunction.Min(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
DatLastDate = Excel.WorksheetFunction.Max(WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)))
IntCounter01 = 1
'Clearing dates.
WksOutput.Range(RngOutputFirstCell.Offset(1, 0), RngOutputFirstCell.End(xlDown)).ClearContents
'Filling dates.
For DatFirstDate = DatFirstDate To DatLastDate
RngOutputFirstCell.Offset(IntCounter01, 0).Value = DatFirstDate
IntCounter01 = IntCounter01 + 1
Next DatFirstDate
Case Is = 7
'Sorting output dates.
With WksOutput.Sort
.SortFields.Clear
.SortFields.Add Key:=RngOutputFirstCell, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range(RngOutputFirstCell, RngOutputFirstCell.End(xlDown))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Marking unique dates.
Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
RngTarget.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],"""",""X"")"
RngTarget.Value = RngTarget.Value
'Sorting output dates by unique values.
With WksOutput.Sort
.SortFields.Clear
.SortFields.Add Key:=RngOutputFirstCell.Offset(0, 1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange Range(RngOutputFirstCell.Offset, RngOutputFirstCell.End(xlDown).Offset(0, 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Clearing double dates.
With WksOutput.Range(RngOutputFirstCell.End(xlDown), RngOutputFirstCell.Offset(0, 1).End(xlDown).Offset(1, 0))
.ClearContents
.ClearFormats
End With
End Select
'Setting RngTarget to cover the results' part of the output.
Set RngTarget = WksOutput.Range(RngOutputFirstCell.Offset(1, 1), RngOutputFirstCell.End(xlDown).Offset(0, 1))
Set RngTarget = RngTarget.Resize(, BytOffset)
RngTarget.FormulaR1C1 = "=VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE)"
'Typing in RngTarget the formula.
'RngTarget.FormulaR1C1 = "=IFERROR(VLOOKUP(RC" & RngOutputFirstCell.column & ",OFFSET(INDIRECT(""" & WksInput.Name & "!R" & RngInputFirstCell.Row + 1 & "C""" & " & MATCH(R" & RngOutputFirstCell.Row & "C," & WksInput.Name & "!" & WksInput.Range(RngInputFirstCell, RngInputFirstCell.End(xlToRight)).Address(, , xlR1C1) & ",0) + " & RngInputFirstCell.column - 1 & ",FALSE),0,-1,5000,2),2,FALSE),0)"
'Transforming formulas into values.
'RngTarget.Value = RngTarget.Value
'Setting RngTarget to select the output data.
Set RngTarget = RngTarget.Offset(0, -1).Resize(, RngTarget.Columns.Count + 1)
'Formatting.
With RngTarget
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
'Setting RngTarget to select the output labels.
Set RngTarget = RngTarget.Offset(-1, 0).Resize(1)
'Formatting.
With RngTarget
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
RngTarget.EntireColumn.AutoFit
Debug.Print "REPORT"; " | "
Debug.Print "WksInput.Parent.Name = WksOutput.Parent.Name ? "; WksInput.Parent.Name = WksInput.Parent.Name; " | "
Debug.Print "WksInput.Name ? "; WksInput.Name; " | "
Debug.Print "RngInputFirstCell.Address ? "; RngInputFirstCell.Address; " | "
Debug.Print "RngInputFirstCell.Value ? "; RngInputFirstCell.Value; " | "
Debug.Print "RngInputFirstCell.Formula ? "; RngInputFirstCell.Formula; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Address ? "; RngInputFirstCell.Offset(1, 0).Address; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Value ? "; RngInputFirstCell.Offset(1, 0).Value; " | "
Debug.Print "RngInputFirstCell.Offset(1,0).Formula ? "; RngInputFirstCell.Offset(1, 0).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Address ? "; RngInputFirstCell.Offset(0, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Value ? "; RngInputFirstCell.Offset(0, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(0,1).Formula ? "; RngInputFirstCell.Offset(0, 1).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Address ? "; RngInputFirstCell.Offset(1, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Value ? "; RngInputFirstCell.Offset(1, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(1,1).Formula ? "; RngInputFirstCell.Offset(1, 1).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Address ? "; RngInputFirstCell.Offset(91, 0).Address; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Value ? "; RngInputFirstCell.Offset(91, 0).Value; " | "
Debug.Print "RngInputFirstCell.Offset(91,0).Formula ? "; RngInputFirstCell.Offset(91, 0).Formula; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Address ? "; RngInputFirstCell.Offset(91, 1).Address; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Value ? "; RngInputFirstCell.Offset(91, 1).Value; " | "
Debug.Print "RngInputFirstCell.Offset(91,1).Formula ? "; RngInputFirstCell.Offset(91, 1).Formula; " | "
Debug.Print "WksOutput.Name ? "; WksOutput.Name; " | "
Debug.Print "RngOutputFirstCell.Address ? "; RngOutputFirstCell.Address; " | "
Debug.Print "RngOutputFirstCell.Value ? "; RngOutputFirstCell.Value; " | "
Debug.Print "RngOutputFirstCell.Formula ? "; RngOutputFirstCell.Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Address ? "; RngOutputFirstCell.Offset(1, 0).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Value ? "; RngOutputFirstCell.Offset(1, 0).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(1,0).Formula ? "; RngOutputFirstCell.Offset(1, 0).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Address ? "; RngOutputFirstCell.Offset(0, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Value ? "; RngOutputFirstCell.Offset(0, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(0,1).Formula ? "; RngOutputFirstCell.Offset(0, 1).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Address ? "; RngOutputFirstCell.Offset(1, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Value ? "; RngOutputFirstCell.Offset(1, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(1,1).Formula ? "; RngOutputFirstCell.Offset(1, 1).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Address ? "; RngOutputFirstCell.Offset(91, 0).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Value ? "; RngOutputFirstCell.Offset(91, 0).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(91,0).Formula ? "; RngOutputFirstCell.Offset(91, 0).Formula; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Address ? "; RngOutputFirstCell.Offset(91, 1).Address; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Value ? "; RngOutputFirstCell.Offset(91, 1).Value; " | "
Debug.Print "RngOutputFirstCell.Offset(91,1).Formula ? "; RngOutputFirstCell.Offset(91, 1).Formula; " | "
End Sub
Bit long, yep. Still it should work. Just make sure to properly set those 4 variables at the beginning (WksInput, WksOutput, RngInputFirstCell, RngOutputFirstCell). Notes will guide you. The code writes on previous output but it doesn't clear it (still it can be modify accordingly). It also apply part of the format you've used in your examples (with more details it's possible to completely edit the format).
If you need any clarification, just say please.
I'm trying to populate a form from another table. I have an identifier (formNumber). The loop's purpose is the find all the rows in the table with the same formNumber, then list the details in a form.
Problem encountered is in the fields using startTableRow, startSubdesc1, startSubdesc2, startRemark. I dont know when they are all repeating the same values, that have already been inputted. An item should only appear once.
Dim wsCurrent As Worksheet, _
loTable1 As ListObject, _
lcColumns As ListColumns, _
lrCurrent As ListRow
Set wsCurrent = Worksheets("Expenses")
Set loTable1 = wsCurrent.ListObjects("Expenses")
Set lcColumns = loTable1.ListColumns
'Loop through and find new entries which haven't been form'd yet
For x = 1 To loTable1.ListRows.Count
Set lrCurrent = loTable1.ListRows(x)
If lrCurrent.Range(1, lcColumns("form sent?").Index) = "" And _
lrCurrent.Range(1, lcColumns("form #").Index) <> "" Then
formNumber = lrCurrent.Range(1, lcColumns("form #").Index).Value
'Set first lines on the form
Worksheets("form").Cells(10, 10).Value = formNumber
'Loop through the Expense sheet and as long as the form number doesn't _
'change, write it to the table on the form
startTableRow = 20
startSubdesc1 = 21
startSubdesc2 = 22
startRemark = 54
Do While lrCurrent.Range(1, lcColumns("form #").Index).Value = formNumber
expensesDate = lrCurrent.Range(1, lcColumns("Date").Index).Value
expensesItem = lrCurrent.Range(1, lcColumns("Description").Index).Value
expensesSubdesc1 = lrCurrent.Range(1, lcColumns("Sub-description 1").Index).Value
expensesSubdesc2 = lrCurrent.Range(1, lcColumns("Sub-description 2").Index).Value
expensesRemarks = lrCurrent.Range(1, lcColumns("Remarks").Index).Value
**Worksheets("form").Cells(startTableRow, 5) = expensesItem
Worksheets("form").Cells(startSubdesc1, 5) = expensesSubdesc1
Worksheets("form").Cells(startSubdesc2, 5) = expensesSubdesc2
Worksheets("form").Cells(startRemark, 3) = expensesRemarks
Worksheets("form").Cells(12, 10) = expensesDate**
lrCurrent.Range(1, lcColumns("form sent?").Index).Value = "Yes"
x = x + 1
startTableRow = startTableRow + 3
startSubdesc1 = startSubdesc1 + 3
startSubdesc2 = startSubdesc2 + 3
startRemark = startRemark + 1
Loop
'Need to subtract one from x to loop through the row again
x = x - 1
'Clear data in table on form
For t = 20 To 45
Worksheets("form").Cells(t, 3).Value = ""
Worksheets("form").Cells(t, 5).Value = ""
Next t
'Clear data in REMARK on form
For r = 54 To 57
Worksheets("form").Cells(r, 3).Value = ""
Next r
End If
Next x
End Sub
End Sub
The problem with your code is in the while loop the lrCurrent does not change. after x = x +1 you need to set
lrCurrent = loTable1.ListRows(x) IF x <= loTable1.ListRows.Count
Also then need to protect against running past the end of table by adding another condition
And x <= loTable1.ListRows.Count
to the Do While line at the start.
Here is an example with fewer variables by using .offset
Sub FillForm()
Dim wb As Workbook, ws As Worksheet, wsForm As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Expenses")
Set wsForm = wb.Sheets("form")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Expenses")
' create look up for column names
Dim ColNum As New Collection
Dim cell As Range, ix As Integer
For Each cell In tbl.HeaderRowRange
ix = ix + 1
ColNum.add ix, cell.Value
Debug.Print cell.Value
Next
' scan table for not sent items
Dim sFormNo As String, rec As Range
Dim iCount As Integer ' count of lnes with same form no
Dim bSearch As Boolean, iSearch As Integer
Dim iRow As Integer
bSearch = False ' search for matching form no
With tbl
For iRow = 1 To .ListRows.Count
Set rec = .ListRows(iRow).Range
If rec(ColNum("form #")) <> "" _
And rec(ColNum("form sent?")) = "" Then
sFormNo = rec(1)
wsForm.Range("J10") = rec(ColNum("form #"))
wsForm.Range("J12") = rec(ColNum("Date"))
bSearch = True
End If
' search rest of table for more records
If bSearch Then
'Clear data in table on form
'wsForm.Range("C20:C45").ClearContents ' required ?
wsForm.Range("E20:C45").ClearContents
wsForm.Range("C54:C57").ClearContents
iCount = 0
' search from existing row down to end
For iSearch = iRow To .ListRows.Count
Set rec = .ListRows(iSearch).Range
' check match
If rec(ColNum("form #")) = sFormNo _
And rec(ColNum("form sent?")) = "" Then
' fill in form
With wsForm.Range("E20").Offset(3 * iCount, 0)
.Offset(0, 0) = rec(ColNum("Description"))
.Offset(1, 0) = rec(ColNum("Sub-description 1"))
.Offset(2, 0) = rec(ColNum("Sub-Description 2"))
End With
wsForm.Range("C54").Offset(iCount, 0) = rec(ColNum("Remarks"))
' update form sent column
rec(ColNum("form sent?")) = "Yes"
iCount = iCount + 1
Debug.Print "Search for " & sFormNo, rec(ColNum("form #")), iCount, iSearch
End If
Next
wsForm.Activate
wsForm.Range("A20").Select
MsgBox iCount & " lines added", vbInformation, "Completed " & sFormNo
bSearch = False
End If
Next
End With
MsgBox "Ended", vbInformation
End Sub