Issue Matching Time Stamped Data

[simoneug]

Hi All, I am having an issue. I have 2 datasets in worksheets in the same workbook say worksheet 1 and worksheet 2. Both Data sets are date and time stamped in columns A and B respectively. I would like to be able to write a macro to search for the matching row of time stamped data in worksheet 1 and 2 then copy both rows of data into a new worksheet, worksheet 3. Not sure if the vlookup function should be used here or if I am better just trying to copy one set of data directly to worksheet 3 and just search for and add the other set of data by matching time stamps. Any help would be greatly appreciated.

 

[simoneug]

I have written this so far but it takes far too long to run and I am not sure if the Vlookup function should be used to try to optimize

Sub TimeStampMatch()
Dim cTime As Variant 'CEMS Time
Dim pTime As Variant 'PEMS Time
Dim cD As Variant 'CEMS Date
Dim pD As Variant 'PEMS Date
Dim k As Integer 'row counter for pems date
Dim i As Integer 'cems and paste row counter
Dim j As Integer 'row counter for pems time

i = 1
'first loop through Cems data to find date and time to match
Do Until IsEmpty(ActiveCell.Value)
Sheets(2).Activate

'Reads CEMS Date and Time to search for
cD = Cells(i, 1).Value
cTime = Cells(i, 2).Text

'optional message box's below to display date and time currently looking for
'MsgBox "CEMS DATE" & cD
'MsgBox "CEMS TIME" & cTime
'Select CEMS data to copy
Range(Cells(i, 1), Cells(i, 5)).Select
Selection.Copy
Sheets(1).Activate
Cells(i, 1).Select
ActiveSheet.Paste
Sheets(3).Activate

j = 1
k = 1
pD = Sheets(3).Cells(k, 1)
pTime = Sheets(3).Cells(j, 2).Text

'Nested Loops look to match date stamp first then time stamp
Do Until cD = pD
k = k + 1
pD = Sheets(3).Cells(k, 1)
Loop
If cD = pD Then
j = 1

Do Until cTime = pTime
j = j + 1
pTime = Sheets(3).Cells(j, 2).Text
Loop
If cTime = pTime Then
'Selects matching Pems date and time stamp data to copy
ActiveSheet.Range(Cells(j, 1), Cells(j, 5)).Select
Selection.Copy
Sheets(1).Activate

'Determine offset for pems data paste
Cells(i, 6).Select
ActiveSheet.Paste

End If

End If




i = i + 1
Loop
End Sub