I have a list of reference #s that I am matching to 2 data sets and if a match is found, the macro will pull certain fields over.
For the 1st database I don't have multiple matches by reference # but in the second database I have multiple matches by reference # and I would like to pull only the most recent entries (preferably 2 or 3).
The code right now will put the data in specific columns; for database 2 in Column H,I,J,K. In case there are up to 3 matches by reference # I would like the code to continue and add the second match in Column L,M,N,O and so on for the third.
The code is below. While I was searching I was wondering if this code might help sorting by date?
Option Explicit
Public Sub TestMe()
Dim dateRanges As Range Set dateRanges = Range("D1:D11")
Dim mn As Variant With Application
mn = .Match(.Min(dateRanges), dateRanges, 0) End With
MsgBox Range("E" & mn).Value2
End Sub
this is the code i have right that is working for simple match
Sub HB_IPT_Rate_Comparison()
Dim KeyCells As Range
Dim Sheet1, Sheet2, sheet3 As Worksheet
Dim CellChanged As Integer
Dim Path, File As String
Dim LastRow, LastData As Long
Dim Found As Boolean
On Error GoTo Handle
Set Sheet1 = Sheets("Comparison Report")
Sheet1.Range("H1").Clear
If Sheet1.Range("H1").Value = "" Then
Sheet1.Range("H1").Value = 0
CellChanged = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
End If
If Sheet1.Cells(Rows.Count, "C").End(xlUp).Row > Sheet1.Range("H1").Value Then
CellChanged = Sheet1.Range("H1").Value + 1
'1st Database Match "CPK"
Set Sheet2 = Sheets("CPK")
LastRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To LastRow
On Error Resume Next
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep
If Sheet1.Range("C" & CellChanged).Value = Sheet2.Range("A" & i) Then
Sheet1.Range("D" & CellChanged).Value = Sheet2.Range("B" & i).Value 'Sum of HB CWGT (KG)
Sheet1.Range("E" & CellChanged).Value = Sheet2.Range("C" & i).Value 'Sum of MB CWGT (KG)
Sheet1.Range("F" & CellChanged).Value = Sheet2.Range("F" & i).Value 'Achiev CPK
Sheet1.Range("G" & CellChanged).Value = Sheet2.Range("H" & i).Value 'Density
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
'2nd Database Match "Orbit"
Set sheet3 = Sheets("Orbit")
CellChanged = Sheet1.Range("H1").Value + 1
LastRow = sheet3.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To LastRow
On Error Resume Next
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep2
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("H" & CellChanged).Value = sheet3.Range("B" & i).Value 'Customer
Sheet1.Range("I" & CellChanged).Value = sheet3.Range("G" & i).Value 'Rate Val start
Sheet1.Range("J" & CellChanged).Value = sheet3.Range("AG" & i).Value 'ATA All in
Sheet1.Range("K" & CellChanged).Value = sheet3.Range("R" & i).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep2:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
Sheet1.Range("H1").Value = CellChanged
End If
Exit Sub
Handle:
MsgBox ("Error")
End Sub
Display More
late for me to ask for help too 