复制和粘贴的宏扩展不起作用

Question

我一直在尝试将这个适用于前 3 张的宏扩展到总共 6 张，但无论我尝试什么，宏似乎都失败了。我这样做的方式有问题吗？

这是原始宏

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

这是我尝试修改的宏，总共 6 张无效。

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

Answer 1

您又添加了 3 个工作表，但尚未更改 arrConfig 的尺寸以容纳它们。它需要像：Dim arrConfig(1,5) as String。您还需要更新存储最后 3 行的数组位置。它现在的工作方式是向数组添加 3 行，然后覆盖这 3 行。

Answer 2

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

复制和粘贴的宏扩展不起作用

Macro expansion for copy and pasting won't work

excel

vba