Match data from multiple w/books & paste row

**khaydon1987** · 11-09-2011, 04:34 PM

Hello,

I have a main spreadsheet which contains order reference numbers (Column B), details of the order are filled out to the right on the same row.

I have 3 identical spreadsheets (for 3 members of staff), they each fill out their own orders on their spreadsheet.

I want their data to be pulled in to the main spreadsheet using a macro. It should look at Column B in the main spreadsheet for order reference numbers; When the reference numbers in this column match to Column B of one of the 3 staff spreadsheets, data in Columns H:R in the staff spreadsheet should be copied to the corresponding columns in the main spreadsheet.

the order reference numbers are unique to the staff members so there shouldn't be an issue with multiple matches.

I'm new to VBA/Macros and haven't been successful trying to adapt existing codes i've found to work. I'm in the process of reading up on VBA/Macros but need to get this up and running asap for work.

Any help would be greatly appreciated!

Thanks, Kev

**tigeravatar** · 11-09-2011, 05:09 PM

Kev,

Hard to know how your data is setup without more information, but I took a stab at it. See attached. It contains a button on the 'Master' sheet which is assigned to the following macro:

Sub tgr()
    
    Dim arrData() As Variant
    Dim r As Long, c As Long
    Dim ws As Worksheet
    Dim rngFound As Range
    
    With Intersect(ActiveSheet.UsedRange, Columns("B"))
        ReDim arrData(1 To .Rows.Count - 1, 1 To 11)
        For r = 1 To UBound(arrData, 1)
            For Each ws In ActiveWorkbook.Sheets
                If ws.Name <> ActiveSheet.Name Then
                    Set rngFound = ws.Columns("B").Find(ActiveSheet.Cells(r + 1, "B").Value)
                    If Not rngFound Is Nothing Then
                        For c = 1 To UBound(arrData, 2)
                            arrData(r, c) = ws.Cells(rngFound.Row, 7 + c).Value
                        Next c
                        Set rngFound = Nothing
                        Exit For
                    End If
                End If
            Next ws
        Next r
    End With
    
    ActiveSheet.Range("H2").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
End Sub

**khaydon1987** · 11-10-2011, 03:26 AM

tigeravatar, thanks so much for the quick reply. It's exactly what i need apart from one bit (and this was my fault, novices, what are you guna do with them!)

The individual staff members fill in their own workbooks, not sheets within one spread;

Main Spreadsheet.xls

Paul.xls
John.xls
Ringo.xls

I want, upon opening of Main Spreadsheet.xls, the data to be pulled from Paul, John and Ringo ..... any ideas?

I promise i will read up and be more au fait with terminology in the future,

Cheers, Kev

**tigeravatar** · 11-10-2011, 11:00 AM

Kev,

The code assumes the individual workbooks are in the same folder as the Master workbook. This code is used in the Workbook_Open event so that it happens automatically when the workbook opens, so it would need to be placed in the ThisWorkbook code module. To have the code run on a button click like in the example I provided, the code would need to be in a standard module, and you should give it a different name (like Sub ImportData).

Here's the updated code:

Private Sub Workbook_Open()
    
    Dim wb1 As Workbook:       Set wb1 = ActiveWorkbook
    Dim ws1 As Worksheet:      Set ws1 = ActiveWorkbook.Sheets(1)
    Dim strFldrPath As String: strFldrPath = wb1.Path & "\"
    Dim CurrentFile As String: CurrentFile = Dir(strFldrPath & "*.xls")
    
    Dim arrData() As Variant
    Dim r As Long, c As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim BCell As Range
    Dim rngFound As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ReDim arrData(1 To wb1.ActiveSheet.UsedRange.Rows.Count - 1, 1 To 11)
    While CurrentFile <> vbNullString
        If CurrentFile <> wb1.Name Then
            Set wb = Workbooks.Open(strFldrPath & CurrentFile)
            Set ws = wb.Sheets(1)
            For Each BCell In ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp))
                Set rngFound = ws1.Columns("B").Find(BCell.Value)
                If Not rngFound Is Nothing Then
                    r = rngFound.Row - 1
                    For c = 1 To UBound(arrData, 2)
                        arrData(r, c) = ws.Cells(BCell.Row, 7 + c).Value
                    Next c
                    Set rngFound = Nothing
                End If
            Next BCell
            wb.Close False
        End If
        CurrentFile = Dir
    Wend
    
    ws1.Range("H2").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

**khaydon1987** · 11-10-2011, 01:33 PM

i can't thank you enough for this, works perfectly

cheers

**khaydon1987** · 11-10-2011, 03:19 PM

sorry, not quite working as i would have liked .... i've attached a draft of the main spreadsheet and an example staff member sheet.

Had a go at amending code but got no where!

what i should have told you is that there are two description rows (1&2), because you didn't know the code was wiping descriptions from row 2. Also it was pulling data from one staff sheet but not another, data in 'B' did match too ..

Any chance you could give it a look for me? Cheers

**khaydon1987** · 11-10-2011, 03:23 PM

now attached, had to remove formatting to reduce file size .... cheers

**tigeravatar** · 11-10-2011, 06:16 PM

Updated code:

Private Sub Workbook_Open()
    
    Dim wb1 As Workbook:       Set wb1 = ActiveWorkbook
    Dim ws1 As Worksheet:      Set ws1 = ActiveWorkbook.Sheets(1)
    Dim strFldrPath As String: strFldrPath = wb1.Path & "\"
    Dim CurrentFile As String: CurrentFile = Dir(strFldrPath & "*.xls")
    
    Dim arrData() As Variant
    Dim c As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim BCell As Range
    Dim rngFound As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ReDim arrData(1 To ws1.UsedRange.Rows.Count - 2, 1 To 11)
    While CurrentFile <> vbNullString
        If CurrentFile <> wb1.Name Then
            Set wb = Workbooks.Open(strFldrPath & CurrentFile)
            Set ws = wb.Sheets(1)
            For Each BCell In ws.Range("B3", ws.Cells(Rows.Count, "B").End(xlUp))
                Set rngFound = ws1.Columns("B").Find(BCell.Value)
                If Not rngFound Is Nothing Then
                    For c = 1 To UBound(arrData, 2)
                        arrData(rngFound.Row - 2, c) = ws.Cells(BCell.Row, 7 + c).Value
                    Next c
                    Set rngFound = Nothing
                End If
            Next BCell
            wb.Close False
        End If
        CurrentFile = Dir
    Wend
    
    ws1.Range("H3").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub