Copy Data From Multiple Workbooks To A Master Workbook

[tip2toe]

Hi all

I have an excel (2010) workbook which contains 1 worksheet called MASTER. This sheet has the headers starting in A1 through E1:

Date
Company Name
Contact
TorV
Details

I want a VBA script that will run from the MASTER worksheet and allow me to select multiple workbooks in a folder and copy the data (from ROW 22) until LAST ROW and add it to the worksheet called MASTER.

I already have a VBA script (shown below so that other users can use) which allows me to select multiple workbooks in a folder and pull out individual cells data but I need to change the script to pull out ROWS data as per the paragraph above.

I have just got back off holiday and my mind is blank as to how to change the script

Many Thanks


Craig:

Sub BulkImport()
   Dim InFileNames As Variant
   Dim OutFileName As String
   Dim fCtr As Long
   Dim tempWkbk As Workbook
   Dim consWks As Worksheet
   Dim destCell As Range
   Dim myRow As Long
   Dim total As Long
   Dim LastRow As Long
   Set consWks = ActiveWorkbook.Sheets(1)
   LastRow = consWks.Range("A65536").End(xlUp).Row
   InFileNames = Application.GetOpenFilename _
   (FileFilter:="Excel Files, *.xl*", MultiSelect:=True)
   Application.ScreenUpdating = False
   If IsArray(InFileNames) Then
      For fCtr = LBound(InFileNames) To UBound(InFileNames)
         Set tempWkbk = Workbooks.Open(Filename:=InFileNames(fCtr))
         consWks.Range("A" & fCtr + LastRow).Value = tempWkbk.Worksheets(1).Range("A22").Value
         consWks.Range("B" & fCtr + LastRow).Value = tempWkbk.Worksheets(1).Range("B22").Value
         consWks.Range("C" & fCtr + LastRow).Value = tempWkbk.Worksheets(1).Range("C22").Value
         consWks.Range("D" & fCtr + LastRow).Value = tempWkbk.Worksheets(1).Range("D22").Value
         consWks.Range("E" & fCtr + LastRow).Value = tempWkbk.Worksheets(1).Range("E22").Value
       ActiveWorkbook.Close
      Next fCtr
   Else
      MsgBox "No file selected"
   End If
   With Application
      .StatusBar = False
      .ScreenUpdating = True
   End With
End Sub

[Excel Fox]

try this..

Sub BulkImport()

   Dim InFileNames As Variant
   Dim fCtr As Long
   Dim tempWkbk As Workbook
   Dim consWks As Worksheet
   Set consWks = ThisWorkbook.Sheets(1)
   InFileNames = Application.GetOpenFilename _
   (FileFilter:="Excel Files, *.xl*", MultiSelect:=True)
   Application.ScreenUpdating = False
   If IsArray(InFileNames) Then
      For fCtr = LBound(InFileNames) To UBound(InFileNames)
        With Workbooks.Open(Filename:=InFileNames(fCtr))
            .Sheets(1).Range("A22:E" & .Sheets(1).Range("A" & .Sheets(1).Rows.Count).End(xlUp).Row).Copy consWks.Range("A" & consWks.Rows.Count).End(xlUp)(2)
            .Close 0
        End With
      Next fCtr
   Else
      MsgBox "No file selected"
   End If
   With Application
      .StatusBar = False
      .ScreenUpdating = True
   End With
   
End Sub

[tip2toe]

Thank you Excel Fox for the script - which works exactly as I envisaged it would.

I also realise that I was declaring names that were not needed in the original script. I use the original script for copying data from Excel quote Forms onto an excel master quotation log.

Thank you again.