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

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

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


"Pman" wrote:

> 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
>
> ***************************************************

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


"Mike H" wrote:

> 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
>
>
> "Pman" wrote:
>
> > 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" wrote:

> 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.