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.