cycle through n files

R

Rossella

I've got a series of operations to do on n excel files
the directory is the same..the names of the files are
0001..0002...0003...0004..until 0067
How can I do that through a macro??
 
R

Ron de Bruin

the problem is that files are 0001..0002..and so on until 0100.

Why problem ?

The code examples loop through all files in the folder

Wat do you want to do?
 
R

Ron de Bruin

Try this

If the first four characters are numeric it use the file in the loop
It use the folder C:\Data

Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
'clear all cells on the first sheet
rnum = 1

Do While FNames <> ""
If IsNumeric(Left(FNames, 4)) Then
Set mybook = Workbooks.Open(FNames)
'Your code
MsgBox FNames
mybook.Close False
End If

FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
 
R

Rossella

is this right?
Sub Prova()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourcerange As Range
Dim destrange As Range
Dim rnum As Long
Dim sourceRcount As Long
Dim Fnames As String
Dim mypath As String


Dim SaveDrivedir As String
SaveDrivedir = CurDir
mypath = "C:\prova"
ChDrive mypath
ChDir mypath

Fnames = ("*.xls")
If Len(Fnames) = 0 Then
MsgBox "Non ci sono file nella directory"
ChDrive SaveDrivedir
ChDir SaveDrivedir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
rnum = 1

Do While Fnames <> ""
If IsNumeric(Left(Fnames, 4)) Then
Selection.Copy
Set mybook = Workbooks.Open(Fnames)
Sheets("Febbraio").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Gennaio").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Marzo").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
ActiveWorkbook.Save

MsgBox Fnames
mybook.Close False
End If

Fnames = Dir()
Loop
ChDrive SaveDrivedir
ChDir SaveDrivedir
Application.ScreenUpdating = True
End Sub
 
R

Ron de Bruin

You want to copy the selection to all workbooks in the folder where the first
four characters are numeric.

Then Try this with a few test files in a folder

see also
http://www.rondebruin.nl/copy4.htm


Sub Prova_test1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim Fnames As String
Dim mypath As String
Dim rng As Range
Dim SaveDrivedir As String

SaveDrivedir = CurDir
mypath = "C:\prova"
ChDrive mypath
ChDir mypath

Fnames = ("*.xls")
If Len(Fnames) = 0 Then
MsgBox "Non ci sono file nella directory"
ChDrive SaveDrivedir
ChDir SaveDrivedir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

Set rng = Selection

Do While Fnames <> ""
If IsNumeric(Left(Fnames, 4)) Then

Set mybook = Workbooks.Open(Fnames)

rng.Copy mybook.Sheets("Febbraio").Range("A1")
rng.Copy mybook.Sheets("Gennaio").Range("A1")
rng.Copy mybook.Sheets("Marzo").Range("A1")

mybook.Close True 'save the file
End If

Fnames = Dir()
Loop
ChDrive SaveDrivedir
ChDir SaveDrivedir
Application.ScreenUpdating = True
End Sub
 
R

Ron de Bruin

I not test it and now I see you change the code from my first example

Use this

Fnames = Dir("*.xls")
If Len(Fnames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDrivedir
ChDir SaveDrivedir
Exit Sub
End If
 
Top