Hi Ron,
This was very useful. Thanks a lot. I adapted it a bit so it can do
translation from source file column to destination file row and it can do
more copies from the same source file. I enclosed my sloppy code (havily
relying on yours) below for information, maybe it is useful for others.
Thanks again,
Rik
== start code snippet
Sub Example2()
' From
http://www.rondebruin.nl/copy3.htm
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim cnum As Long
'Fill in the path\folder where the files are
'MyPath = "\\ComputerName\YourFolder"
MyPath = "D:\Test\origs"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
basebook.Worksheets(1).Cells.Clear
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'start row
rnum = 2
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
cnum = 1
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Call My_Do_It("b9:b11", basebook, mybook, rnum, cnum)
Call My_Do_It("b23:b27", basebook, mybook, rnum, cnum)
Call My_Do_It("g36", basebook, mybook, rnum, cnum)
rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
Private Sub My_Do_It(ByVal Cellen As String, basebook As Workbook, mybook As
Workbook, rnum As Long, cnum As Long)
Set sourceRange = mybook.Worksheets(1).Range(Cellen)
SourceRcount = sourceRange.Rows.Count
With sourceRange
Set destrange = basebook.Worksheets(1).Cells(1, cnum). _
Resize(.Rows.Count, .Columns.Count)
End With
For x = 1 To SourceRcount
destrange.Cells(rnum, x).Value = sourceRange.Cells(x, 1).Value
Next x
cnum = cnum + SourceRcount
End Sub
== end code snippet