Code:
Option Explicit
Sub DoItForADay()
Rem 1 Worksheets info
Dim WsTp As Worksheet, WsDta As Worksheet, WsSmry As Worksheet
Set WsTp = ThisWorkbook.Worksheets("Template"): Set WsDta = ThisWorkbook.Worksheets("Datadump"): Set WsSmry = ThisWorkbook.Worksheets("Summary")
Rem 2 The days and source list
' 2a) Put all info in an array
Dim LrDta As Long: Let LrDta = WsDta.Range("A" & WsDta.Rows.Count & "").End(xlUp).Row
Dim arrAllDts() As Variant ' In the naxt line, the .Value Property ( method ) , is used to return in one go all Values in the range. They are returned as a field, ( array ) of values in held in Variant type elements. So we must use Variant for the Dim ing of the type of our Elements, or else the next code line will error , with a Mismatch error
Let arrAllDts = WsDta.Range("A4:M" & LrDta & "").Value ' I am adding column M for my own amusement
' 2b)
' 2c) make an array with all unique identifier for each voucher
Dim Cnt As Long
For Cnt = 1 To UBound(arrAllDts(), 1) ' Looping effectively from forth row until last row in Datadump
Dim Idt As String
Let Idt = arrAllDts(Cnt, 1) & "_" & arrAllDts(Cnt, 8) & " - " & arrAllDts(Cnt, 9) ' I am adding a "_" to in between the date and source info : Later I can split the unique identifiers string by this "_" in order to get the date and souce info
Let arrAllDts(Cnt, 13) = Idt
Dim strDtsSrc As String
If InStr(1, strDtsSrc, Idt, vbBinaryCompare) = 0 Then
Let strDtsSrc = strDtsSrc & Idt & "###"
Else
' case we already have the date in our string, strDts
End If
Next Cnt
Let strDtsSrc = Left(strDtsSrc, (Len(strDtsSrc) - 3)) ' take off the last space "###" which we do not need
'Debug.Print strDtsSrc
' 2d)
Dim arrUnicDtsSrc() As String
Let arrUnicDtsSrc() = Split(strDtsSrc, "###", -1)
Let Worksheets("arrUnicDtsSrc").Range("A1").Resize(1, (UBound(arrUnicDtsSrc()) + 1)).Value = arrUnicDtsSrc() ' arrUnicDtsSrc().jpg --- https://imgur.com/QX1bJMB
Worksheets("arrUnicDtsSrc").Columns.AutoFit
Let Worksheets("arrAllDts").Range("A4:M" & LrDta & "").Value = arrAllDts()
' The next code line can be removed to get all the 19 worksheets
ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line, then you will see that all dates and sources will be considered
Rem 3 ' === Main Outer loop ============================================================
Dim Stear As Variant ' For Each unique identifier . In VBA,
For Each Stear In arrUnicDtsSrc() ' Doing stuff For Each unique identifier
'3a) work out how many rows and which row indicies with the current unique identifier
Dim DteSrcRwCnt As Long
For Cnt = 1 To UBound(arrAllDts(), 1) ' ----------------------Going through all data rows
If arrAllDts(Cnt, 13) = CStr(Stear) Then ' I am looking for rows in the main datadump that have the current unique identifier
'3a)(i) counting rows
' Debug.Print Cnt + 3 & " " & arrAllDts(Cnt, 13)
Let DteSrcRwCnt = DteSrcRwCnt + 1 ' counting the rows for the current unique identifier
'3a)(ii) get the (row) indicies for the current unique identifier. Later i need the row number of all the rows corresponding to the current unique identifier
Dim strRws As String
Let strRws = strRws & Cnt + 3 & " " ' I later wont the actual row in the datadump worksheet, so that is 3 higher than the "row" number in arrAllDts() because I captured just the range from the 4th row -- "A4:M........
Else
End If
Next Cnt ' ----------------------Going through all data rows
Let strRws = Left(strRws, (Len(strRws) - 1)) ' Take of last " " which I do not need
Dim arrRws() As String ' The VBA string function returns field of string type elements. So I must Dim my array elements appropriately
Let arrRws() = Split(strRws, " ", -1, vbBinaryCompare) ' This gives us an array which is the row numbers in the Datadump for this unique identifier
Let ThisWorkbook.Worksheets("arrRws").Range("A1").Resize(1, (UBound(arrRws()) + 1)).Value = arrRws() ' arrRws().JPG - https://imgur.com/HDgpyQq -
ThisWorkbook.Worksheets("arrRws").Columns.AutoFit
'3b) In the "Magic Code line" below we need a "vertical" array https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Dim arrRwsT() As Long
ReDim arrRwsT(1 To UBound(arrRws()) + 1, 1 To 1) ' a "Vertical" 1 column array
For Cnt = 1 To UBound(arrRws()) + 1
Let arrRwsT(Cnt, 1) = arrRws(Cnt - 1)
Next Cnt
Let ThisWorkbook.Worksheets("arrRwsT").Range("A1:A" & UBound(arrRws()) + 1 & "").Value = arrRwsT() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Rem 4 Make Vouchers for current unique identifier, Stear
' 4a)
Dim arrVouch() As Variant ' https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Let arrVouch() = WsTp.Range("A1:K24").Value
' 4b) An array just containing the rows for the current Idt
Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:N)") ' {1, 2, 3, 4......14} - Clms().jpg - https://imgur.com/xHlUeH9
Dim arrDtsSrc() As Variant ' For "Magic Code line" https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Let arrDtsSrc() = Application.Index(WsDta.Cells, arrRwsT(), Clms()) ' - --"Magic Code line" - arrDtsSrc().JPG : https://imgur.com/0c8SgIn
Let ThisWorkbook.Worksheets("arrDtsSrc").Range("A1").Resize(UBound(arrDtsSrc(), 1), UBound(arrDtsSrc(), 2)).Value = arrDtsSrc() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Dim RwCnt As Long: Let RwCnt = 1: Let Cnt = 1
' 4c)
Do While RwCnt < DteSrcRwCnt + 1 ' ............................................
Do While Cnt < 11 ' _________________________________|
' Fill in values in Voucher Array
Let arrVouch(Cnt + 9, 1) = "'" & arrDtsSrc(RwCnt, 2) ' The extra "'" is one way to keep the leading 0s
Let arrVouch(Cnt + 9, 4) = arrDtsSrc(RwCnt, 3) ' Detail ( Item )
Let arrVouch(Cnt + 9, 7) = arrDtsSrc(RwCnt, 4) ' Unit Code
Let arrVouch(Cnt + 9, 9) = arrDtsSrc(RwCnt, 11) ' Value
Let Cnt = Cnt + 1
Let RwCnt = RwCnt + 1
Loop ' While Cnt < 11 ' ______________________________|
Let arrVouch(6, 3) = Split(Stear, "_", 2, vbBinaryCompare)(1) ' The second array element (1) is source code & source name ( The first array element (0) is the date )
Let arrVouch(4, 10) = Split(Stear, "_", 2, vbBinaryCompare)(0) ' The first array element (0) is the date
Let Cnt = 1 ' back to first row for a template
'4d) Information to the summary sheet.
Dim NxtVch As Long: Let NxtVch = WsSmry.Range("A" & WsSmry.Rows.Count & "").End(xlUp).Row
Let WsSmry.Range("A" & NxtVch + 1 & "").Value = "V" & Format(NxtVch, "0000")
Let WsSmry.Range("B" & NxtVch + 1 & "").Value = Split(Stear, "_", 2, vbBinaryCompare)(0)
WsSmry.Hyperlinks.Add Anchor:=WsSmry.Range("C" & NxtVch + 1 & ""), Address:="", SubAddress:="V" & Format(NxtVch, "0000") & "!A1", TextToDisplay:="Go To Sheet"
'4e) Add next voucher
WsTp.Copy After:=WsDta
Let ActiveSheet.Name = "V" & Format(NxtVch, "0000")
Let ThisWorkbook.Worksheets("arrVouch").Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch() ' - arrRwsT().JPG - https://imgur.com/syf0PaZ
Let ActiveSheet.Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch()
Let arrVouch() = WsTp.Range("A1:K24").Value ' get a new template array
Loop ' While RwCnt < DteSrcRwCnt ' .............................................
Let DteSrcRwCnt = 0 ' ready for next Idt Stear
Next Stear ' === Main Outer loop =========================================================================
End Sub
Reply With Quote
Bookmarks