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]

Please enclose your code in Code tags:

http://www.mrexcel.com/forum/misc.php?do=bbcode#code

 

[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

 

[Andrew Poulsom]

You forget the More code. You need to move what's already there. Try:

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
    Dim ws As Worksheet
'   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(Array("Sheet2", "Sheet3"))
                    With ws
                        Set sourceRange = .Range("A1:C1")
'                       More code
                        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 With
                Next ws
            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

 

[Myproblem]

thx andrew, but it still give us data from one sheet data, not and other one

i think I am going to give up - it is so mess for me VBA these days

 

[Myproblem]

adrew, thx you again
i figure out how to resolve this issue.
I figure out to merge selected sheets in one workbook, and many other workbooks. This code is here http://www.rondebruin.nl/copy2.htm.

After that, merge just one sheet (basicly the same named) from many different workooks (this was my issue in this thread).
Code for this is http://www.rondebruin.nl/copy3.htm