A VBA Lookup: XLookup
A Quick Fix (Slow) - Main
Sub CheckTimeAudited_Method()
Const JOIN_DELIMITER As String = "@"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Sheets("AuditData")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srgRoom As Range: Set srgRoom = sws.Range("A3", sws.Cells(slRow, "A"))
Dim srgDate As Range: Set srgDate = srgRoom.EntireRow.Columns("D")
Dim srgTime As Range: Set srgTime = srgRoom.EntireRow.Columns("E")
Dim sLookup() As String
sLookup = JoinTwoSingleColumnRanges(srgRoom, srgDate, JOIN_DELIMITER)
' Destination
Dim dws As Worksheet: Set dws = wb.Sheets("Main")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "AK").End(xlUp).Row
Dim drgRoom As Range: Set drgRoom = dws.Range("AK3", dws.Cells(dlRow, "AK"))
Dim drgDate As Range: Set drgDate = drgRoom.EntireRow.Columns("F")
Dim drgTime As Range: Set drgTime = drgRoom.EntireRow.Columns("X")
' Lookup
Application.ScreenUpdating = False
Dim dTimeCell As Range, r As Long, dLookup As String
For Each dTimeCell In drgTime.Cells
r = r + 1
dLookup = CStr(drgRoom.Cells(r)) & JOIN_DELIMITER & CStr(drgDate.Cells(r))
dTimeCell.Value _
= Application.XLookup(dLookup, sLookup, srgTime, "no match")
Next dTimeCell
Application.ScreenUpdating = True
' Inform.
MsgBox "Data checked.", vbInformation
End Sub
A Quick Fix (Slow) - Help - JoinTwoSingleColumnRanges
Function JoinTwoSingleColumnRanges( _
ByVal rg1 As Range, _
ByVal rg2 As Range, _
Optional ByVal JoinDelimiter As String = "@") _
As String()
Dim rCount As Long: rCount = rg1.Rows.Count
Dim sData() As String: ReDim sData(1 To rCount, 1 To 1)
Dim r As Long
For r = 1 To rg1.Rows.Count
sData(r, 1) = CStr(rg1.Cells(r).Value) & JoinDelimiter _
& CStr(rg2.Cells(r).Value)
Next r
JoinTwoSingleColumnRanges = sData
End Function
An Even Quicker Fix (Slow, Not Recommended) - Using the Function
Using the function with your code, you could replace the invalid TableArrayRoom & TableArrayDate with
JoinTwoSingleColumnRanges(TableArrayRoom, TableArrayDate, "")
An Improvement (Fast) - Main
Sub CheckTimeAudited()
' Constants
' Source
Const SRC_SHEET As String = "AuditData"
Const SRC_FIRST_CELL As String = "A3"
Dim sLookupColumns(): sLookupColumns = VBA.Array(4, 1) ' D, A
Const SRC_RETURN_COLUMN As Long = 5 ' E
' Destination
Const DST_SHEET As String = "Main"
Const DST_FIRST_CELL As String = "A3"
Dim dLookupColumns(): dLookupColumns = VBA.Array(6, 37) ' F, AK
Const DST_RETURN_COLUMN As Long = 24 ' X
Const JOIN_DELIMITER As String = "@"
Const IF_NO_MATCH_VALUE As String = "no match"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim srg As Range: Set srg = RefRangeUR(wb, SRC_SHEET, SRC_FIRST_CELL)
Dim slJag(): slJag = GetJaggedColumnsFromRange(srg, sLookupColumns)
Dim slData() As String: slData = JoinJaggedColumns(slJag, JOIN_DELIMITER)
Dim srData(): srData = GetSingleColumnRange(srg.Columns(SRC_RETURN_COLUMN))
Dim sDict As Object: Set sDict = DictColumns(slData, srData)
' Destination
Dim drg As Range: Set drg = RefRangeUR(wb, DST_SHEET, DST_FIRST_CELL)
Dim dlJag(): dlJag = GetJaggedColumnsFromRange(drg, dLookupColumns)
Dim dlData() As String: dlData = JoinJaggedColumns(dlJag, JOIN_DELIMITER)
Dim drData(): drData = GetLookupData(dlData, sDict, IF_NO_MATCH_VALUE)
Dim drrg As Range: Set drrg = drg.Columns(DST_RETURN_COLUMN)
drrg.Value = drData
MsgBox "Data checked.", vbInformation
End Sub
An Improvement (Fast) - Help - RefRangeCR
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet ('WorksheetID') of a workbook ('wb'),
' references the range from a cell ('FirstCellAddress')
' to the last cell of the given cell's current region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefRangeCR( _
ByVal wb As Workbook, _
ByVal WorksheetID As Variant, _
ByVal FirstCellAddress As String) _
As Range
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetID)
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim lCell As Range:
With fCell.CurrentRegion
Set lCell = .Cells(.Cells.CountLarge)
End With
If lCell.Row < fCell.Row Or lCell.Column < fCell.Column Then Exit Function
Dim rg As Range: Set rg = ws.Range(fCell, lCell)
Set RefRangeCR = rg
End Function
An Improvement (Fast) - Help - RefRangeUR
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a worksheet ('WorksheetID') of a workbook ('wb'),
' references the range from a cell ('FirstCellAddress')
' to the last cell of the worksheet's used range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefRangeUR( _
ByVal wb As Workbook, _
ByVal WorksheetID As Variant, _
ByVal FirstCellAddress As String) _
As Range
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetID)
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim lCell As Range:
With ws.UsedRange
Set lCell = .Cells(.Cells.CountLarge)
End With
If lCell.Row < fCell.Row Or lCell.Column < fCell.Column Then Exit Function
Dim rg As Range: Set rg = ws.Range(fCell, lCell)
Set RefRangeUR = rg
End Function
An Improvement (Fast) - Help - GetJaggedColumnsFromRange
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from columns ('ColumnIndices') of a range
' ('rg') in 2D one-based (single-column) arrays
' of the resulting jagged array.
' Calls: GetSingleColumnrange
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetJaggedColumnsFromRange( _
ByVal rg As Range, _
ColumnIndices() As Variant) _
As Variant()
Dim JLB As Long: JLB = LBound(ColumnIndices)
Dim JUB As Long: JUB = UBound(ColumnIndices)
Dim Jag() As Variant: ReDim Jag(JLB To JUB)
Dim j As Long
For j = JLB To JUB
Jag(j) = GetSingleColumnRange(rg.Columns(ColumnIndices(j)))
Next j
GetJaggedColumnsFromRange = Jag
End Function
An Improvement (Fast) - Help - GetSingleColumnRange
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from a column ('ColumnIndex') of a range
' ('rg') in a 2D one-based (single-column) array.
' In Excel: '=INDEX(rg,,ColumnIndex)'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSingleColumnRange( _
ByVal rg As Range, _
Optional ByVal ColumnIndex As Long = 1) _
As Variant()
Dim Data() As Variant
With rg.Columns(ColumnIndex)
Dim rCount As Long: rCount = .Rows.Count
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else
Data = .Value
End If
End With
GetSingleColumnRange = Data
End Function
An Improvement (Fast) - Help - JoinJaggedColumns
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the joined ('JoinDelimiter') strings of each row
' of each (same-sized) 2D one-based single-column array
' of a jagged array ('JaggedColumns'),
' in a 2D one-based single-column String typed array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function JoinJaggedColumns( _
JaggedColumns() As Variant, _
Optional ByVal JoinDelimiter As String = "@") _
As String()
Dim JLB As Long: JLB = LBound(JaggedColumns)
Dim JUB As Long: JUB = UBound(JaggedColumns)
Dim RUB As Long: RUB = UBound(JaggedColumns(JLB), 1)
Dim sData() As String: ReDim sData(1 To RUB, 1 To 1)
Dim j As Long, r As Long, Delimiter As String
For j = JLB To JUB
For r = 1 To RUB
sData(r, 1) = sData(r, 1) & Delimiter & CStr(JaggedColumns(j)(r, 1))
Next r
Delimiter = JoinDelimiter
Next j
JoinJaggedColumns = sData
End Function
An Improvement (Fast) - Help - DictColumns
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique strings from a 2D one-based single-column
' String typed array ('KeyColumn') in the keys of a dictionary,
' and returns the values from another same-sized Variant typed
' array ('ItemColumn') in the associated items of the dictionary.
' Each associated item is the one that appears in the same row
' as the row of the first occurence of each key.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumns( _
KeyColumn() As String, _
ItemColumn() As Variant) _
As Object
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 1 To UBound(KeyColumn, 1)
If Not dict.Exists(KeyColumn(r, 1)) Then
dict(KeyColumn(r, 1)) = ItemColumn(r, 1)
End If
Next r
Set DictColumns = dict
End Function
An Improvement (Fast) - Help - GetLookupData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Looks up each string of a 2D one-based single-column
' string-typed array ('LookupData') in the keys of a dictionary
' ('LookupDictionary') and for each found string, returns
' the associated item in a same-sized variant-typed array.
' If the string is not found,
' a given value ('IfNoMatchValue') is returned.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetLookupData( _
LookupData() As String, _
ByVal LookupDictionary As Object, _
Optional ByVal IfNoMatchValue As Variant = "") _
As Variant()
Dim rCount As Long: rCount = UBound(LookupData, 1)
Dim Data(): ReDim Data(1 To rCount, 1 To 1)
Dim r As Long, rStr As String
For r = 1 To rCount
rStr = LookupData(r, 1)
If LookupDictionary.Exists(rStr) Then
Data(r, 1) = LookupDictionary(rStr)
Else
Data(r, 1) = IfNoMatchValue
End If
Next r
GetLookupData = Data
End Function
