Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I need
to copy in date order
Thanks!

Dim dt as Date, i as Long
Dim rng as Range, rw as Long
set sh1 = Activesheet
for i = 0 to 30
dt = dateSerial(2005,1,1)
set bk = Nothing
On Error Resume Next
set bk = Workbooks.Open("C:\MyFolder\MyFile" & _
format(dt + i,"yymmdd") & ".xls"
On Error goto 0
if not bk is nothing then
set rng = bk.worksheets(1).Range(A337:A383").SpecialCells(xl Constants)
rw = sh1.Cells(rows.count,2).End(xlup)
if rw < 1 then rw = rw + 1
rng.copy Destination:=Sh1.Cells(rw,2)
bk.close SaveChanges:=False
End if
Next

Change dateSerial to reflect the first day you want to copy from.

--
Regards,
Tom Ogilvy


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

Thanks for the reply Tom
If I have the 'copy to' workbook in the directrory where the daily files are
stored how would I modify the code. I want to be able to copy this file to
the new month and then run it and not have to modify the path in the code
Thanks
Sandy

"Tom Ogilvy" wrote:

Dim dt as Date, i as Long
Dim rng as Range, rw as Long
set sh1 = Activesheet
for i = 0 to 30
dt = dateSerial(2005,1,1)
set bk = Nothing
On Error Resume Next
set bk = Workbooks.Open("C:\MyFolder\MyFile" & _
format(dt + i,"yymmdd") & ".xls"
On Error goto 0
if not bk is nothing then
set rng = bk.worksheets(1).Range(A337:A383").SpecialCells(xl Constants)
rw = sh1.Cells(rows.count,2).End(xlup)
if rw < 1 then rw = rw + 1
rng.copy Destination:=Sh1.Cells(rw,2)
bk.close SaveChanges:=False
End if
Next

Change dateSerial to reflect the first day you want to copy from.

--
Regards,
Tom Ogilvy


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Constants)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

Im getting Run Time Error 76 Path not found on line:
Set oFolder = oFSO.GetFolder(sFolder)
Thanks!

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Constants)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

DUH!!!
I didnt change path! Still trying to figure that part out
Thanks!

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Constants)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

OK I changed sFolder = "C:\MyTest" to sFolder=ThisWorkbook.Path
And the code is opening the files. However it is not copying the range as
specified.
What did I do wrong?

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Formulas)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

Try this which caters for no data, and NG wrap

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
On Error Resume Next
Set rng = _
.Worksheets(1).Range("A337:A383").SpecialCells(xlC onstants)
On Error GoTo 0
If Not rng Is Nothing Then
iRow = oSh.Cells(Rows.Count, 2).End(xlUp).Row
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
End If
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub




--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...

OK I changed sFolder = "C:\MyTest" to sFolder=ThisWorkbook.Path
And the code is opening the files. However it is not copying the range as
specified.
What did I do wrong?

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Formulas)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the
contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a
new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

Change xlFormulas to xlConstants

--
Regards,
Tom Ogilvy


"Sandy" wrote in message
...

OK I changed sFolder = "C:\MyTest" to sFolder=ThisWorkbook.Path
And the code is opening the files. However it is not copying the range as
specified.
What did I do wrong?

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Formulas)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the
contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a
new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

The cells to be copied are populated with formulae, so shouldnt it be
xlformulas?
Thanks

"Tom Ogilvy" wrote:

Change xlFormulas to xlConstants

--
Regards,
Tom Ogilvy


"Sandy" wrote in message
...

OK I changed sFolder = "C:\MyTest" to sFolder=ThisWorkbook.Path
And the code is opening the files. However it is not copying the range as
specified.
What did I do wrong?

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Formulas)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the
contents of
A337:A383 ommitting every other cell (Blanks) and paste them into a
new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls and I
need
to copy in date order
Thanks!

And we would know that how? So, yes, based on this new information - it
should stay xlFormulas

You said it wasn't copying anything, so that was my best guess. Otherwise,
it should copy as you described. Bob got the same impression I see.

--
Regards,
Tom Ogilvy

"Sandy" wrote in message
...
The cells to be copied are populated with formulae, so shouldnt it be
xlformulas?
Thanks

"Tom Ogilvy" wrote:

Change xlFormulas to xlConstants

--
Regards,
Tom Ogilvy


"Sandy" wrote in message
...

OK I changed sFolder = "C:\MyTest" to sFolder=ThisWorkbook.Path
And the code is opening the files. However it is not copying the
range as
specified.
What did I do wrong?

"Bob Phillips" wrote:

Sub ProcessFiles()
Dim oFSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim this As Workbook
Dim iRow As Long
Dim oSh As Worksheet
Dim rng As Range

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set this = ActiveWorkbook
Set oSh = ActiveSheet
sFolder = "C:\MyTest"
If sFolder < "" Then
Set oFolder = oFSO.GetFolder(sFolder)
Set oFiles = oFolder.Files
For Each oFile In oFiles
If oFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open FileName:=oFile.Path
With ActiveWorkbook
Set rng =
..Worksheets(1).Range("A337:A383").SpecialCells(xl Formulas)
iRow = oSh.Cells(Rows.Count, 2).End(xlUp)
If iRow < 1 Then iRow = iRow + 1
rng.Copy Destination:=oSh.Cells(iRow, 2)
.Close SaveChanges:=False
End With
End If
Next oFile

End If ' sFolder < ""

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Sandy" wrote in message
...
Hi
I need to open all files in a specified directory and copy the
contents of
A337:A383 ommitting every other cell (Blanks) and paste them into
a
new
book
in a column starting in b1. The files are n ame myfileyymmdd.xls
and I
need
to copy in date order
Thanks!