copy specific cells from closed workbook

[arron]

Hello all,
I'm attempting to write a macro that will copy specific cells (ie. R3 or K15) to a master workbook. i also need this marco to look through every workbook in a user chosen folder for these cells (all workbooks only contain a singe worksheet). i managed to accomplish this with word documents by working with some code i found online but i cant seem to make it work for excel files; this code is attached to the command button of the document below.it previously worked by looking for markers and observing what came after them, but im not even sure that will work in excel. i should also mention that im still pretty new to both vba and the forum.
thank you for any help you can provide.
19478

[Leith Ross]

Hello arron,

After looking at your workbook and the code, I find this is a bit confusing. Your "Sheet1" has the headers: Date,To,Re,INVOICE,Class,Cost Per Individual,Non-Member Trainees,COST. Yet, you only want to import import a single cell, either R3 or K15 from each workbook.

The macro code which is written in Word VBA and is outputting to the ActiveSheet in Excel works only with Word documents. There is too much information missing in your post to make sense of what you want to do.

I would be best if you describe what you want to accomplish step by step in words and give examples when needed. Don't shorten your explanation because you think it may be too long. Better too much information than too little.

[arron]

thanks for your response Leith. the headers correspond to data on another docment. the desired out put, or final product i suppose, would be a macro that can open a user selected file, open each excel document within and copy/paste a range of specific cells (one cell for each named column on sheet1), then move onto the next blank row and do the same. i should note that the data that im looking for will always be in the same cells. i only listed R3 and K15 as examples

[Leith Ross]

Hello arron,

Are the documents being opened laid out the same as the Master workbook, i.e. same columns, rows, and headers?

[arron]

No, unfortunately they are not, the data lies in cells C11, C15, C23, I11, I12, C29, C28, I29 respectively

[Leith Ross]

Hello arron,

This macro should do what need. It lets the user select a folder, finds all xlsx workbooks in the folder, opens each workbook and copies the information to the Master sheet, and closes the workbook.

The new data is copied to the next empty row on the Master.



Sub CollectData()


Dim DstRng As Range
Dim DstWks As Worksheet
Dim EndRow As Long
Dim File As Object
Dim Folder As Variant
Dim oFiles As Object
Dim oShell As Object
Dim SrcWkb As Worksbook
Dim SrcWks As Worksheet

Set DstWks = ThisWorkbook.Worksheets("Sheet1")

Set DstRng = DstWks.Range("A2:H2")

EndRow = DstWks.Cells(Rows.Count, "A").End(xlUp).Row

If EndRow >= DstRng.Row Then
Set DstRng = DstRng.Offset(EndRow - DstRng.Row + 1, 0)
End If

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count > 0 Then
Folder = .SelectedItems(1)
Else
MsgBox "Action Cancelled", vbOKOnly + vbInformation
Exit Sub
End If
End With

Set oShell = CreateObject("Shell.Application")

Set Folder = oShell.Namespace(Folder)

Set oFiles = Folder.Items
oFiles.Filter 64, "*.xlsx"

Application.ScreenUpdating = False

For Each File In oFiles
Set SrcWkb = Workbooks.Open(File)
Set SrcWks = SrcWkb.Worksheets(1)
With SrcWks
' The data lies in cells C11, C15, C23, I11, I12, C29, C28, I29 respectively.
DstRng.Cells(1, "A") = .Range("C12")
DstRng.Cells(1, "B") = .Range("C15")
DstRng.Cells(1, "C") = .Range("C23")
DstRng.Cells(1, "D") = .Range("I11")
DstRng.Cells(1, "E") = .Range("I12")
DstRng.Cells(1, "F") = .Range("C29")
DstRng.Cells(1, "G") = .Range("C28")
DstRng.Cells(1, "I") = .Range("I29")
End With
SrcWkb.Close SaveChanges:=False
Set DstRng = DstRng.Offfset(1, 0)
Next File

Application.ScreenUpdating = True

End Sub

[arron]

wow, thanks a lot for the help Ross, this is much more than i expected. but there seems to be some sort of issue. i select the folder but it produces run-time error 1004 application defined or object defined error. the error occurs on line

Set SrcWkb = Workbooks.Open(File)
i should mention that i made a slight alteration to your code, i changed

Dim SrcWkb As Worksbook to:

Dim SrcWkb As Workbook
because i assumed the s in worksbook was a mistake

[Leith Ross]

Hello arron,

Yes, you are correct. It should be Workbook. There is another typo in the code (Thanks Yasser!).

Wrong:


Set DstRng = DstRng.Offfset(1, 0)


Correct:


Set DstRng = DstRng.Offset(1, 0)

[arron]

Hi, Leith
ive made the appropriate adjustments, however the result is still the same. it appears to be having trouble either locating the file or opening it. when i run the script from a command button it "could not find "book1.xlsx"" (book1.xlsx is the name of the first file in the folder). ive tried to enter the folder in the window that it opens but it does not show any files. i have had success with files of different layouts though so i will try again and update you from there

[Leith Ross]

Hello arron,

The problem with opening the file was I forgot to add the Path reference to the Folder. Here is corrected and tested code.



Sub CollectData()

Dim DstRng As Range
Dim DstWks As Worksheet
Dim EndRow As Long
Dim File As Object
Dim Folder As Variant
Dim oFiles As Object
Dim oShell As Object
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet

Set DstWks = ThisWorkbook.Worksheets("Sheet1")

Set DstRng = DstWks.Range("A2:H2")

EndRow = DstWks.Cells(Rows.Count, "A").End(xlUp).Row

If EndRow >= DstRng.Row Then
Set DstRng = DstRng.Offset(EndRow - DstRng.Row + 1, 0)
End If

With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count > 0 Then
Folder = .SelectedItems(1)
Else
MsgBox "Action Cancelled", vbOKOnly + vbInformation
Exit Sub
End If
End With

Set oShell = CreateObject("Shell.Application")

Set Folder = oShell.Namespace(Folder)

Set oFiles = Folder.Items
oFiles.Filter 64, "*.xlsx"

Application.ScreenUpdating = False

For Each File In oFiles
Set SrcWkb = Workbooks.Open(File.Path)
Set SrcWks = SrcWkb.Worksheets(1)
With SrcWks
' The data lies in cells C11, C15, C23, I11, I12, C29, C28, I29 respectively.
DstRng.Cells(1, "A") = .Range("C12")
DstRng.Cells(1, "B") = .Range("C15")
DstRng.Cells(1, "C") = .Range("C23")
DstRng.Cells(1, "D") = .Range("I11")
DstRng.Cells(1, "E") = .Range("I12")
DstRng.Cells(1, "F") = .Range("C29")
DstRng.Cells(1, "G") = .Range("C28")
DstRng.Cells(1, "I") = .Range("I29")
End With
SrcWkb.Close SaveChanges:=False
Set DstRng = DstRng.Offset(1, 0)
Next File

Application.ScreenUpdating = True

End Sub

[arron]

hey, Leith
you are brilliant. thank you so much for all the help. it works perfectly and i hope others are able to benefit from this.

[Leith Ross]

Hello arron,

I apologize for the errors in the code and thanks to Yasser for the PM about the typos. Glad we got it working.