copy content from Multiple file to one file

[Pman]

Hi,

I currently have a folder which contains close to 800+ excel files. I need
to copy a range of cells from each of these files to another excel file. I'm
writing a Macro to do this, however It's not working.

I was wondering if someone could go through my code and let me know where I
made a mistake.

Thanks,
Prash

***************************************************
The Code
***************************************************
Sub Macro1()

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set Folder = oFSO.GetFolder("C:\OCFs")

Workbooks.Open Filename:="C:\OCF Destination\Book1.xls"

For Each file In Folder.Files

If file.Type Like "*Excel*" Then
Workbooks.Open Filename:=file.Path

' Unmerging and copying
'
Columns("D").Select
Selection.UnMerge
Range("D7").Select
ActiveWindow.SmallScroll Down:=-6
Range("D1").Select
ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("D1").Select
ActiveWindow.SmallScroll Down:=42
Range("D166").Select
Selection.Copy
Workbooks.Open Filename:="C:\OCF Destination\Book1.xls"
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=True

ActiveWorkbook.Close SaveChanges:=True

End If

Next file
Set oFSO = Nothing


End Sub

***************************************************

 

[Mike H]

Hi,

The problem with recorded macros is they generate an awful lot of
unnecessary code and this has happened in your case. If I understand
correctly you are trying to paste D1 to D66 of each workbook into another
after first unmerging cells and putting a formula in d1. Try this instead.

It goes in the receiving workbook (Book1 in your code). Note there are 2
subs. A general one to open every excel file in a folder and the second to do
the copying.
The copied data is then paste into Book 1



Dim File As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder("c:\") ' Change to suit
For Each File In Folder.Files

If File.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=Folder.Path & "\" & File.Name

'Call your macro
dothings
ActiveWorkbook.Close True
lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("A" & lastrow + 1).PasteSpecial
End If
Next
End Sub
Sub dothings()
With ActiveWorkbook.ActiveSheet
..Range("D").UnMerge
..Range("D1").Formula = "=CELL(""filename"")"
..Range("D166").Copy
End With
End Sub

Mike

 

[Mike H]

missed some code when pasting

Sub OpenFiles()
Dim FSO As Object
Dim Folder As Object
Dim File As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder("c:\") ' Change to suit
For Each File In Folder.Files

If File.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=Folder.Path & "\" & File.Name

'Call your macro
dothings
ActiveWorkbook.Close True
lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("A" & lastrow + 1).PasteSpecial
End If
Next
End Sub

Sub dothings()
With ActiveWorkbook.ActiveSheet
..Range("D").UnMerge
..Range("D1").Formula = "=CELL(""filename"")"
..Range("D166").Copy
End With
End Sub

 

[Pman]

Hi,

The problem with recorded macros is they generate an awful lot of
unnecessary code and this has happened in your case. If I understand
correctly you are trying to paste D1 to D66 of each workbook into another
after first unmerging cells and putting a formula in d1. Try this instead.

It goes in the receiving workbook (Book1 in your code). Note there are 2
subs. A general one to open every excel file in a folder and the second to do
the copying.
The copied data is then paste into Book 1

Thanks a lot a lot a lot Mike. What you said is true, I've unmerged cells,
put a formula in D1, and copied a range to a new file. But I knew I was
missing something since I compiled this macro using a couple of recorded
Macros.

Thanks so much again.