VBA code to match certain rows and paste the respective data

Hi, I'm stuck with few tasks on the project im working on. I would be really grateful if anyone can help me with this,

So Basically my source data will be in worksheet named “Data”.

• In Data, we have to match the number in ColumnF in each row to cell A2 in each worksheet other than Data. Once the number is matched, further operations will be conducted on that matched sheet
• Now, for each row in sheet Data, in its respective matched sheet, we will match the “SKU Number” in the corresponding cell of ColumnQ of Data with each row of ColumnA of the matched sheet.
• For matched SKU Number in the matched Sheet, we will match the date in ColumnD of Data with the respective date column in the matched sheet
• Last, we will paste the “Itm Qty” from ColumnS in Data in the matched date column of the matched sheet

An example of how the program will work, as sheet ‘Data’ in F2 has Sold-to number as ‘123’, from all the spreadsheet cell A2 we matched the respective number ‘123’ which is found to be in sheet named as ‘COSCO’. Now, we will match the cell Q2 value ‘4567’ to column A of ‘COSCO’. When it is matched, in that row we will match cell D2 ‘2-Feb’ with the date columns in ‘COSCO’. When dates are matched, we will copy cell S2 value ‘9’ in the matched date cell. I have uploaded the file for your reference.

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("A2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("A:A").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

@Mumps

As this program is a part of a bigger project, this code isnt working in that document i have updated the document according to the masterfile doc, kindly see that the rows are starting from columBI as it was starting before from ColumnA. Kindly help me edit the above code.

THANKYOU SOOO MUCH FOR ALL THE HELP

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("A2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("A:A").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

Mumps More clear version of the doc i have t2o (2) tables having same date columns i want this code to run for the table starting from ColumnBI. doc attached

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("BI2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("BI:BI").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Rows(3).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

Apologies for this inconvenience, really sorry but can you look at my post#4. this code is perfectly fine but data is pasted in the both the tables as i want it to get pated in the table starting from ColumBI its getting overlapped because of the file having two tables with same dates in column

Quote from Mumps

Try:

Code

Sub Matchdata()
    Application.ScreenUpdating = False
    Dim rng As Range, rng2 As Range, RngList As Object, ws As Worksheet, srcWS As Worksheet, fnd As Range, key As Variant
    Dim strdate As String, LastRow As Long, fDate As Range
    Set srcWS = Sheets("Data")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each rng In srcWS.Range("F2:F" & LastRow)
        If Not RngList.Exists(rng.Value) Then
            RngList.Add rng.Value, Nothing
        End If
        For Each key In RngList
            With srcWS.Cells(1).CurrentRegion
                .AutoFilter 6, key
                For Each ws In Sheets
                    If ws.Range("BI2") = key Then
                        With srcWS
                            For Each rng2 In .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible)
                                Set fnd = ws.Range("BI:BI").Find(rng2.Offset(, 11), LookIn:=xlValues, lookat:=xlWhole)
                                If Not fnd Is Nothing Then
                                    strdate = rng2.Offset(, -2)
                                    Set fDate = ws.Range("BI3").Resize(, ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column - 60).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)
                                    ws.Cells(fnd.Row, fDate.Column) = rng2.Offset(, 13)
                                End If
                            Next rng2
                        End With
                    End If
                Next ws
            End With
        Next key
    Next rng
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Display More

there is an error in this line

Set fDate = ws.Range("BI3").Resize(, ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column - 60).Find(CDate(strdate), LookIn:=xlFormulas, lookat:=xlWhole)

Error for your reference

Yes i am using on the same file in the post#4 and still have this error, its just im clearing the already filled data in that file to check wether the code is working

Well, actually you prolly running the file where data has been already uploaded if you refresh the file its not working ,i have attached the same file below but i clear the quantity already filled in the table to check if the code is working and have the same error

Quote from Mumps

The attached file shows the results I get when I run the macro.

i have attached the same file below but i clear the quantity already filled in the table to check if the code is working and have the same error

Quote from Mumps

The attached file shows the results I get when I run the

Worked! thankyou for all the help

Mumps

Hi. I wish you well. Kindly look into the little problem im facing on the following thread.

Matching Specific Rows and Copy to specific colums. URGENT!

Thankyou

Quote from Mumps

My pleasure.