Macro expansion for copy and pasting won't work

user_19085230 0
Viewed 42

I've been trying to expand this macro which works for the first 3 sheets to a total of 6 sheets, but no matter what I try the macro seems to fail. Is there a problem with the way I'm doing it ?

Here's the original macro

Public Sub copyData()

Dim arrConfig(1, 2) As String
'Target sheetname | Source filename
arrConfig(0, 0) = "10k I": arrConfig(1, 0) = "1.xls"
arrConfig(0, 1) = "10k B": arrConfig(1, 1) = "2.xls"
arrConfig(0, 2) = "10k C": arrConfig(1, 2) = "3.xls"

'...
'arrconfig(0,6) = ...

Const pathDownloads As String = "/Users/bob/Downloads/"
Const AddressToCopy As String = "A1:M150"

Dim i As Long, wbSource As Workbook, wsSource As Worksheet, wsTarget As Worksheet

For i = 0 To UBound(arrConfig, 2)
    Set wsTarget = ThisWorkbook.Worksheets(arrConfig(0, i))
    wsTarget.Cells.Clear
    
    Set wbSource = Workbooks.Open(pathDownloads & arrConfig(1, i))
    Set wsSource = wbSource.Worksheets(1)
    
    'This is the part where the data are written from one range to another (values only without formatting)
    wsTarget.Range(AddressToCopy).Value = wsSource.Range(AddressToCopy).Value
    
    wbSource.Close savechanges:=True
Next

End Sub

And here's the macro I tried to modify for a total of 6 sheets which does not work.

Public Sub copyData()

Dim arrConfig(1, 2) As String
'Target sheetname | Source filename
arrConfig(0, 0) = "10k I": arrConfig(1, 0) = "1.xls"
arrConfig(0, 1) = "10k B": arrConfig(1, 1) = "2.xls"
arrConfig(0, 2) = "10k C": arrConfig(1, 2) = "3.xls"
arrConfig(0, 0) = "10Q I": arrConfig(1, 0) = "4.xls"
arrConfig(0, 1) = "10Q B": arrConfig(1, 1) = "5.xls"
arrConfig(0, 2) = "10Q C": arrConfig(1, 2) = "6.xls"
'...


Const pathDownloads As String = "/Users/bob/Downloads/"
Const AddressToCopy As String = "A1:M150"

Dim i As Long, wbSource As Workbook, wsSource As Worksheet, wsTarget As Worksheet

For i = 0 To UBound(arrConfig, 2)
    Set wsTarget = ThisWorkbook.Worksheets(arrConfig(0, i))
    wsTarget.Cells.Clear
    
    Set wbSource = Workbooks.Open(pathDownloads & arrConfig(1, i))
    Set wsSource = wbSource.Worksheets(1)
    
    'This is the part where the data are written from one range to another (values only without formatting)
    wsTarget.Range(AddressToCopy).Value = wsSource.Range(AddressToCopy).Value
    
    wbSource.Close savechanges:=True
Next

End Sub
vba excel
2 Answers

You have added 3 more worksheets, but you haven't changed the dimensions of arrConfig to accommodate them. It needs to be like: Dim arrConfig(1,5) as String. You'll also need to update the array positions you're storing those last 3 rows as. The way it works right now, you are adding 3 rows to your array, and then overwriting those 3 rows.

user_137050500 
Sub CopyData()

    Const SourceFolderPath As String = "C:\Users\bob\Downloads\"
    Const SourceRangeAddress As String = "A1:M150"
    
    'Target sheetname | Source filename
    Dim ArrConfig(0 To 1, 0 To 5) As String
    ArrConfig(0, 0) = "10k I": ArrConfig(1, 0) = "1.xls"
    ArrConfig(0, 1) = "10k B": ArrConfig(1, 1) = "2.xls"
    ArrConfig(0, 2) = "10k C": ArrConfig(1, 2) = "3.xls"
    ArrConfig(0, 3) = "10Q I": ArrConfig(1, 3) = "4.xls"
    ArrConfig(0, 4) = "10Q B": ArrConfig(1, 4) = "5.xls"
    ArrConfig(0, 5) = "10Q C": ArrConfig(1, 5) = "6.xls"
    
    Application.ScreenUpdating = False
    
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim i As Long
    
    For i = 0 To UBound(ArrConfig, 2)
        
        Set wbSource = Workbooks.Open(SourceFolderPath & ArrConfig(1, i))
        Set wsSource = wbSource.Worksheets(1)
        
        Set wsTarget = ThisWorkbook.Worksheets(ArrConfig(0, i))
        wsTarget.Cells.Clear
        
        wsTarget.Range(SourceRangeAddress).Value _
            = wsSource.Range(SourceRangeAddress).Value
        
        wbSource.Close SaveChanges:=False ' you're just reading
    
    Next

    'ThisWorkbook.Save

    Application.ScreenUpdating = True
    
    MsgBox "Data copied.", vbInformation

End Sub
user_98140690
Related