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

Myproblem

Board Regular
Joined
May 24, 2010
Messages
198
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
 

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).

Andrew Poulsom

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092
More like:

Code:
    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

Legend
Joined
Jun 19, 2002
Messages
63,650
You would need to loop

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

Myproblem

Board Regular
Joined
May 24, 2010
Messages
198
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

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092

ADVERTISEMENT

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

Board Regular
Joined
May 24, 2010
Messages
198
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

MrExcel MVP
Joined
Jul 21, 2002
Messages
73,092

ADVERTISEMENT

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

Myproblem

Board Regular
Joined
May 24, 2010
Messages
198
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
 

Myproblem

Board Regular
Joined
May 24, 2010
Messages
198
#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
 

Forum statistics

Threads
1,136,953
Messages
5,678,749
Members
419,782
Latest member
gc75150

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top