Multi Source Data Copy Macro

Question

Hi all,

I wrote this macro with the help of the internet. Assume you have lots of source files in a directory that you want to copy all data from (ex headers) and paste the data into a single master spreadsheet.

I want the user to be able to browse to their source folder using a folder select dialogue and then the rest of the macro should run as per the code. However, it seems to break because of the myfile definition i.e. it is a folder name and then wildcard for all the available excel files. ( Workbooks.Open foldername & myFile)

any help would be greatly appreciated as to how to fix this. I am by no means an expert.

Thanks

Sub MultiFileSource()

'Sets the name for the two "in use" files

Dim foldername As String

 With Application.FileDialog(msoFileDialogFolderPicker)

   .AllowMultiSelect = False

   .Show

   On Error Resume Next

   foldername = .SelectedItems(1)

   Err.Clear

   On Error GoTo 0

 End With

 Dim myFile As String, myCurrFile As String, counter As Integer

    myCurrFile = ThisWorkbook.Name

    'myFile = Dir("C:\Users\Rob\Desktop\Excel\SourceData\*.xls")  'set the path to where all the source files are copied to

    myFile = Dir(foldername & "\*.xlsx")

'loops a lookup of each file in the source directory copying all data except the 1st row (to avoide dupe headers)

'then copies that data to the master file at the next available blank row

Do Until myFile = ""

 Workbooks.Open foldername & myFile    'set the path to where all the source files are copied to

 Workbooks(myFile).Activate

 ActiveCell.Offset(1, 0).Select

 Range(Selection, Selection.SpecialCells(xlLastCell)).Select

  Selection.Copy

 Workbooks(myCurrFile).Activate

    Range("A1").Select

    ActiveCell.End(xlDown).Offset(1, 0).Select

    ActiveSheet.Paste

  Workbooks(myFile).Close savechanges:=False

 counter = counter + 1

 myFile = Dir

Loop

MsgBox ("Finished and processed " & counter & " files") 'This displayes a message box inc. the value of Counter

End Sub

Answer 1

You have not followed my suggestion which was to

Dim xlBook as Workbook

and replace

Workbooks.Open foldername & myFile    'set the path to where all the source files are copied to

 Workbooks(myFile).Activate

with

Set xlBook = Workbooks.Open(foldername & myFile)

xlBook.Activate   

I also have serious reservations that the rest of your code will work once you get past the present error.

If you send me the dummy files and master files, I will come up with some code for you that does not require cells to be selected or copied and pasted.

Answer 2

Hi Doug,

ive update the code with file and folder open dialogues to specify both the source folder and the master spreadsheet. Its still bugging out on opening the first source file in the source folder. Ive also tried to neaten up the layout.

FYI these files are just dummy files containing a set of column headers in row 1 and 6 lines of random numbers. In the real world situation I want to use this code for, the files will be in the same structure, just more headers and 00's of rows. The master file is the same grid layout but is initially blank except for the headers which have been prenamed, mirrored from the source file.

I've underlined where the debug occurs.

thanks for your help

Sub MultiFileSource()

 Dim foldername As String

 Dim myFile As String

 Dim myCurrFile As String

 Dim counter As Integer

 Dim xlbook As Workbook

 With Application.FileDialog(msoFileDialogFolderPicker)

   .AllowMultiSelect = False

   .Show

   On Error Resume Next

   foldername = .SelectedItems(1)

   Err.Clear

   On Error GoTo 0

 End With

   myCurrFile = Application.GetOpenFilename(Title:="Please select the 'master' file")

  myFile = Dir(foldername & "\.xlsx")   'myFile = Dir("C:\Users\Rob\Desktop\Excel\SourceData\.xls")  'set the path to where all the source files are copied to

 Do Until myFile = "" 'loops a lookup of each file in the source directory copying all data except the 1st row (to avoide dupe headers)'then copies that data to the master file at the next available blank row

  Workbooks.Open myFile    'set the path to where all the source files are copied to

  Workbooks(myFile).Activate

  ActiveCell.Offset(1, 0).Select

  Range(Selection, Selection.SpecialCells(xlLastCell)).Select

   Selection.Copy

  Workbooks(myCurrFile).Activate

     Range("A1").Select

     ActiveCell.End(xlDown).Offset(1, 0).Select

     ActiveSheet.Paste

   Workbooks(myFile).Close savechanges:=False

  counter = counter + 1

  myFile = Dir

 Loop

MsgBox ("Finished and processed " & counter & " files") 'This displayes a message box inc. the value of Counter

End Sub

Answer 3

There is probably no ActiveCell.  You probably need to specify the Worksheet that contains the data

Where is the data that you want to copy.  Particularly in relation to the other data in the sheet

If you want to send me a couple of the "source" workbooks and the workbook into which you want to insert the data, I'll give you the code that you should be using.

Answer 4

Hi, thanks for your reply.

Im getting a 1004 runtime error:

"sorry, we couldn't find

C:\Users\rob\desktop\excel\sourcedatasource1.xlsx. is it possible it was removed, renamed....etc.

note that the path that should be uses is C:\Users\rob\desktop\excel\source data

and the first file in the directory is called source1.xls.

I tried modding this line with a back slash: Set xlbook = Workbooks.Open(foldername & "" & myFile), but when I do that I get an "Application defined or object defined error", debug highlights this line : ActiveCell.End(xlDown).Offset(1, 0).Select

any ideas why this is happening??

thanks

Answer 5

Try adding

Dim xlBook as Workbook

and replace

Workbooks.Open foldername & myFile    'set the path to where all the source files are copied to

 Workbooks(myFile).Activate

with

Set xlBook = Workbooks.Open(foldername & myFile)

xlBook.Activate   

and also replace

Workbooks(myFile).Close savechanges:=False

with

xlBook.Close savechanges:=False