Initial coding for solution to this Thread
http://www.excelfox.com/forum/showth...ll=1#post11124
File : "Data Sheet.xls" : https://app.box.com/s/wvusyk3ish5z3mxdwvw3sw9n683m58rq
Code:
Option Explicit '
Sub HaiderAdSlots1() ' 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("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets("Sheet2")
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 & "").Value2: 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 arrays to identify rows ... " Channel Name & Date & Time "
Dim arrInId() As String
ReDim arrInId(1 To Lr2)
Dim cnt As Long
For cnt = 2 To Lr2
Let arrInId(cnt) = arrInSht2(cnt, 1) & " | " & arrInSht2(cnt, 2) & " | " & arrInSht2(cnt, 3)
Next cnt
Dim arrOutId() As String
ReDim arrOutId(1 To Lr1)
For cnt = 2 To Lr1
Let arrOutId(cnt) = arrOutSht1(cnt, 2) & " | " & arrOutSht1(cnt, 1) & " | " & arrOutSht1(cnt, 3)
Next cnt
Rem 3 match up rows in data sheets
For cnt = 2 To Lr1
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrOutId(cnt), arrInId(), 1) ' return the position along of a match ( looking for arrOutId(cnt) , in arrInId() , 1 indicates approximate match )
If Not IsError(MtchRes) Then
'3b)
Let arrOutSht1(cnt, 4) = arrInSht2(MtchRes, 3)
Else
End If
Next cnt
Rem 4
Let ThisWorkbook.Worksheets("OutputTest").Range("A1").Resize(UBound(arrOutSht1(), 1), 4).Value = arrOutSht1()
End Sub
Bookmarks