Code:
Option Explicit '
Sub HaiderAdSlots_v3() ' http://www.excelfox.com/forum/showthread.php/2330-Fill-Column-Based-on-Actual-Time?p=11124&viewfull=1#post11124
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("Sheet1v3"): Set Ws2 = ThisWorkbook.Worksheets("Sheet2v3")
Dim Lr1 As Long, Lr2 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "").Row: Let Lr2 = Ws1.Range("A" & Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row & "").Row
'1b) data arrays, original data
Dim arrInSht2() As Variant, arrOutSht1() As Variant
Let arrInSht2() = Ws2.Range("A1:G" & Lr2 + 1 & "").Value2 ' !!! I need +1 as a "bodge workaroung to prevent an index out of range error --- here
Let arrOutSht1() = Ws1.Range("A1:C" & Lr1 & "").Value2
'1b)(ii) extra "column" for outout
ReDim Preserve arrOutSht1(1 To Lr1, 1 To 4) ' we may add a last dimension, but must keep the others the same as they were
Rem 2 Group ident arrays, for convenience
'2a) an array of the idents for all data rows in output sheet1
Dim arrOutId() As String
ReDim arrOutId(1 To Lr1)
Dim cnt As Long
For cnt = 2 To Lr1 ' Channel Date in Long number form Hour as number
Let arrOutId(cnt) = arrOutSht1(cnt, 2) & " | " & arrOutSht1(cnt, 1) & " | " & CLng(Hour(arrOutSht1(cnt, 3))) ' add to array of all idents in rows 2 to last row
Next cnt
'2b) idents for input historical data, includung an additonal arrray of just the unique ident values
Dim arrInId() As String
ReDim arrInId(1 To Lr2 + 1)
For cnt = 2 To Lr2 ' Channel Date in Long number form Hour as number
Let arrInId(cnt) = arrInSht2(cnt, 1) & " | " & arrInSht2(cnt, 2) & " | " & CLng(arrInSht2(cnt, 7)) ' add to array of all idents in rows 2 to last row
Dim strEnucsIds As String: ' a string of unique idents to be used to create an additonal arrray of just the unique ident values
If InStr(1, strEnucsIds, arrInId(cnt), vbBinaryCompare) = 0 Then Let strEnucsIds = strEnucsIds & arrInId(cnt) & "####"
Next cnt
Let strEnucsIds = Left(strEnucsIds, Len(strEnucsIds) - 4) ' takes off last "####"
Dim arrEnucsIds() As String: Let arrEnucsIds() = Split(strEnucsIds, "####", -1, vbBinaryCompare) ' additonal arrray of just the unique ident values
Dim CntIds As Long: Let CntIds = UBound(arrEnucsIds()) + 1 ' +1 because the index numbers of array generated by Split function goes like 0 1 2 3 4 ... etc. So the total number of elements is 1 more than the ubound: .... (Ubound gives the index number of the last element, not necerssarily the numberr of elements)
'Debug.Print strEnucsIds
'2c) We know the number of unique idents , so can assign an array, a groupings array, to hold each group of times
Dim arrGrpTimes() As Variant ' I must use variant, as that is the only thing that can hild an array - i will be putting arrasy of the AdStart times in the second dimension ("second column")
ReDim arrGrpTimes(1 To CntIds, 1 To 2) ' The first column has the unique ID, and the second column will be itself an array of the historical AdStart times for that group
Rem 3 Looping to build groupings array
Dim HisCnt As Long ' MAIN LOOP Count for rows of historical data ================================================
Let HisCnt = 1 ' this is so +1 gives the start at row 2, so as not to consider the header ....**
Do While HisCnt < Lr2
Dim GrpCnt As Long ' this will be used for the first dimension("row") of our
Dim strTimes As String: Let strTimes = " " ' reset for next group of AdStart times
Let GrpCnt = GrpCnt + 1 ' reset to index/first dimension("row") next group of AdStart times
Do ' This INNER LOOP will be repeated for each group -------------------------INNER LOOP
Let HisCnt = HisCnt + 1 ' this effectively "goes down" each row in data Sheet2 - starting at row 2 ....**
Let strTimes = strTimes & arrInSht2(HisCnt, 3) & " "
Loop While arrInId(HisCnt + 1) = arrInId(HisCnt) ' !!! ---here --INNER LOOP
Let strTimes = Trim(strTimes) ' takes off leading and trailing spaces
'Debug.Print strTimes
' at the end of each inner loop, we have the data needed to add the AdStart data for this group
Let arrGrpTimes(GrpCnt, 1) = arrEnucsIds(GrpCnt - 1) ' -1 is because arrEnucsIds() starts at index number 0 , like index numbers go 0 1 2 3 4 ... etc.
Dim arrTemp() As String ' temporary array to build each array of AdStart times
Let arrTemp() = Split(strTimes, " ", -1, vbBinaryCompare)
Let arrGrpTimes(GrpCnt, 2) = arrTemp()
Loop ' MAIN LOOP Count for rows of historical data ================================================
Rem 4 Going through ("down") the output, Sheet1, data , and adding a New Time at each "row"
For cnt = 2 To Lr1 ' MAIN LOOP for Count for rows in Sheet1 ===================================================
'4b) determine to which group the "row" belongs
Dim MtchRes As Variant ' The next line will either return a whole number of the "position along" that it fids a match, or it will return a VBA error type. So a variant for the Variable must be used
Let MtchRes = Application.Match(arrOutId(cnt), arrEnucsIds(), 0) ' return the position along of a match ( looking for arrOutId(cnt) , in the array of unique Ids arrEnucsIds() , 0 indicates excact match ) ....._- note the array of unique Ids is determined from the Ids in input historical data
If Not IsError(MtchRes) Then '4b)(i) - time to get a time, form the array { "20:19:12" , "20:19:32" , "20:49:12" , ….etc } of times for this Id group
Dim arrTempTimes() As String ' for the array , { "20:19:12" ,........ } , of times
Let arrTempTimes() = arrGrpTimes(MtchRes, 2) ' I can assign a dynamic array to any other array, as long as the types, ( String) in this case are the same. The wanted array is in the second column of the array, arrGrpTimes()
Rem 5 "Getting the random times bit"...
Dim RndIndx As Long: Randomize: Let RndIndx = Int(Rnd() * (UBound(arrTempTimes()) + 1)) ' like IntegerOf(Rnd()*(N+1))
Let arrOutSht1(cnt, 4) = arrTempTimes(RndIndx)
Else '4b(ii). This is the case of no unique Id as determined from the Ids in input historical data, arrEnucsIds() ....._- so this may occur if ..." if in any case there is no spot aired in Sheet2 on a specific channel, date and timeslot then New Time will be same as start time...."
Let arrOutSht1(cnt, 4) = arrOutSht1(cnt, 3) ' ...".....if in any case there is no spot aired in Sheet2 on a specific channel, date and timeslot then New Time will be same as start time....."
End If
Next cnt ' MAIN LOOP for Count for rows in Sheet1 =============================================================
Rem 6 Output test
Let ThisWorkbook.Worksheets("OutputTestv3").Range("A1").Resize(UBound(arrOutSht1(), 1), 4).Value = arrOutSht1()
End Sub
Reply With Quote
Bookmarks