VBA IndexMatch then Paste Values

[phillip87]

The below correctly checks the date and pastes in the values into the correct sheet/column.

However.......

1. I am needing this to paste under the date not over the top of it
2. I need this to only copy the values where both the date and category match

Sheet 2 is a dynamic table so the categories may or may not be listed depending on if they have a value which is why I need to INDEXMATCH rather than just copy a range.

Sub findAndCopy()
  Dim foundCell As Range, sh2, sh As Worksheet
 
  'Set sheets
  Set sh2 = Sheets("Refresh Data Report")
  Set sh3 = Sheets("Ongoing Record")
 
  'Find string in column C of Sheet2
  Set foundCell = sh3.Range("B:H").Find(sh2.Range("AP1").Value, , xlValues, xlWhole)
  If Not foundCell Is Nothing Then 'If match cell is found
    sh2.Range("AI3:AI30").Copy
    foundCell.PasteSpecial xlPasteValues
    foundCell.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
  Else
    Call MsgBox("Not found the match cell!", vbExclamation, "Finding String")
  End If
End Sub

 

[phillip87]

I still don't see what value is in AP1.

AP1 is just todays date so when they click the record button it shifts the values of the listed categories into the ongoing record shown in the 'Capture' image. that part works fine however I need it to also just copy the values of the categories shown rather than the whole list like it does now.

 

[Candyman8019]

Give something like this a try:

Sub findandcopy()
    Dim sh3 As Worksheet
    Dim sh2 As Worksheet
    Dim dateToFind As Date
    Dim colToUpdate As Integer
    Dim lrowsh3 As Long
    Dim lrowsh2 As Long
    Dim i As Long, j As Long

    ' Set worksheets
    Set sh3 = ThisWorkbook.Sheets("Ongoing Record")
    Set sh2 = ThisWorkbook.Sheets("Refresh Data Report")

    ' Get the date from cell AP1 in Refresh Data Report
    dateToFind = sh2.Range("AP1").Value

    ' Find the column in Ongoing Record that matches the date
    For i = 2 To 8 ' Columns B to H
        If sh3.Cells(1, i).Value = dateToFind Then
            colToUpdate = i
            Exit For
        End If
    Next i

    ' If no matching date is found, exit the sub
    If colToUpdate = 0 Then
        MsgBox "Date not found in Ongoing Record"
        Exit Sub
    End If

    ' Get the last rows in both sheets
   lrowsh3 = sh3.Cells(sh3.Rows.Count, "A").End(xlUp).Row
   lrowsh2 = sh2.Cells(sh2.Rows.Count, "AA").End(xlUp).Row

    ' Loop through categories in Refresh Data Report and update values in Ongoing Record
    For i = 2 To lrowsh2
        For j = 2 To lrowsh3
            If sh2.Cells(i, "AA").Value = sh3.Cells(j, "A").Value Then
                sh3.Cells(j, colToUpdate).Value = sh2.Cells(i, "AI").Value
                Exit For
            End If
        Next j
    Next i

    MsgBox "Ongoing Record updated successfully!"
End Sub

 

[phillip87]

Give something like this a try:

Sub findandcopy()
    Dim sh3 As Worksheet
    Dim sh2 As Worksheet
    Dim dateToFind As Date
    Dim colToUpdate As Integer
    Dim lrowsh3 As Long
    Dim lrowsh2 As Long
    Dim i As Long, j As Long

    ' Set worksheets
    Set sh3 = ThisWorkbook.Sheets("Ongoing Record")
    Set sh2 = ThisWorkbook.Sheets("Refresh Data Report")

    ' Get the date from cell AP1 in Refresh Data Report
    dateToFind = sh2.Range("AP1").Value

    ' Find the column in Ongoing Record that matches the date
    For i = 2 To 8 ' Columns B to H
        If sh3.Cells(1, i).Value = dateToFind Then
            colToUpdate = i
            Exit For
        End If
    Next i

    ' If no matching date is found, exit the sub
    If colToUpdate = 0 Then
        MsgBox "Date not found in Ongoing Record"
        Exit Sub
    End If

    ' Get the last rows in both sheets
   lrowsh3 = sh3.Cells(sh3.Rows.Count, "A").End(xlUp).Row
   lrowsh2 = sh2.Cells(sh2.Rows.Count, "AA").End(xlUp).Row

    ' Loop through categories in Refresh Data Report and update values in Ongoing Record
    For i = 2 To lrowsh2
        For j = 2 To lrowsh3
            If sh2.Cells(i, "AA").Value = sh3.Cells(j, "A").Value Then
                sh3.Cells(j, colToUpdate).Value = sh2.Cells(i, "AI").Value
                Exit For
            End If
        Next j
    Next i

    MsgBox "Ongoing Record updated successfully!"
End Sub

That works amazingly, thank you so much for this. It is a big work around as Outlook will not allow us to auto pull data complete with the categories assigned to an email so this will help immensely.

 

[Candyman8019]

You’re welcome. Happy to help.