Modify Ron´s VBA code and help me with Worksheet Array

[Myproblem]

I need to copy the same range from many sheets in the same workbook.
I found Ron´s VBA solution, which basicly fits to me partly because this code below copy only specific range just from one sheet in specific workbook.
But, I need to copy specific range from many sheets and i tried to modified this VBA in the part as I colored in red, but it does not work:
The specific range is the same like: A1:C10 etc.
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With

to be:
On Error Resume Next
With mybook.Worksheets(Array("Sheet2", "Sheet3"))
Set sourceRange = .Range("A1:C1")
End With

__________
Original VBA code below, reference to Ron and source:
http://www.rondebruin.nl/copy3.htm


#If VBA7 Then Declare PtrSafe Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long#Else Declare Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long#End IfSub ChDirNet(szPath As String) SetCurrentDirectoryA szPathEnd SubSub Basic_Example_2() Dim MyPath As String Dim SourceRcount As Long, Fnum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With SaveDriveDir = CurDir ChDirNet "C:\Users\Ron\test" FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _ MultiSelect:=True) If IsArray(FName) Then 'Add a new workbook with one sheet Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 'Loop through all files in the array(myFiles) For Fnum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(1) Set sourceRange = .Range("A1:C1") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else 'if SourceRange use all columns then skip this file If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else 'Copy the file name in column A With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(Fnum) End With 'Set the destrange Set destrange = BaseWks.Range("B" & rnum) 'we copy the values from the sourceRange to the destrange With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next Fnum BaseWks.Columns.AutoFit End IfExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ChDirNet SaveDriveDirEnd Sub</PRE>
Please help, or suggest new solution
thx

 

[Andrew Poulsom]

More like:

    Dim ws As Worksheet
    On Error Resume Next
    For Each ws In mybook.Worksheets(Array("Sheet2", "Sheet3"))
        With ws
            Set SourceRange = .Range("A1:C1")
'           More code
        End With
    Next ws

 

[VoG]

You would need to loop

Dim ws As Worksheet
For Each ws In mybook.Worksheets(Array("Sheet2", "Sheet3"))
    Set SourceRange = ws.Range("A1:C1")
'more code
Next ws

 

[Myproblem]

thx guys but seems to me these suggested solutions (basicly the same) overwrite data and it is not ok for me because the data form one sheet should be below each other (maybe I forgot to mention it)
or I am wrong how to implement your´s suggested solutinons

any other tips

 

[Andrew Poulsom]

What we posted doesn't write any data so it can't overwrite any. What code did you put in the For Each ... Next loop?

 

[Myproblem]

I did this below, I mean I replace this
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With

with

On Error Resume Next
For Each ws In mybook.Worksheets(ArrayArray("Sheet2", "Sheet3"))
With ws
Set sourceRange = .Range("A1:C1")
' More code
End With

Next ws

 

[Andrew Poulsom]

That's still not writing anything. Post all your code.

 

[Myproblem]

complete code below

#If VBA7 Then Declare PtrSafe Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long#Else Declare Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long#End IfSub ChDirNet(szPath As String) SetCurrentDirectoryA szPathEnd SubSub Basic_Example_2() Dim MyPath As String Dim SourceRcount As Long, Fnum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With SaveDriveDir = CurDir ChDirNet "C:\Users\Ron\test" FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _ MultiSelect:=True) If IsArray(FName) Then 'Add a new workbook with one sheet Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 'Loop through all files in the array(myFiles) For Fnum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next
For Each ws In mybook.Worksheets(ArrayArray("Sheet2", "Sheet3"))
With ws
Set sourceRange = .Range("A1:C1")
' More code
End With

End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else 'if SourceRange use all columns then skip this file If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else 'Copy the file name in column A With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(Fnum) End With 'Set the destrange Set destrange = BaseWks.Range("B" & rnum) 'we copy the values from the sourceRange to the destrange With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next Fnum BaseWks.Columns.AutoFit End IfExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ChDirNet SaveDriveDirEnd Sub

 

[Andrew Poulsom]

That's unreadable. Try again.

 

[Myproblem]

#If VBA7 Then
Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If

Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Basic_Example_2()
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\Users\Ron\test"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
For Each ws In mybook.Worksheets(ArrayArray("Sheet2", "Sheet3"))
With ws
Set sourceRange = .Range("A1:C1")
' More code
End With

Next ws

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub