VBA 根据条件将数据从工作簿复制到另一个工作簿

Question

我有 2 个工作簿，一个源工作簿的数据分布在不同的工作表上，一个目标工作簿需要将这些数据复制到一张工作表上，并位于彼此的正下方。

将数据从源复制到目标是基于源工作簿中的工作表名称的条件。根据此标准，应使用特定的复制方法（即特定的列顺序）将数据复制到目标工作簿。

例如下面我在源工作簿上有一个工作表“apple”，当满足此条件时，应将特定顺序的 culumns 复制到目标工作表。 下面的目标表上有不同的香蕉等复制方法。

这是我到目前为止所拥有的，但它不起作用：

Public wbsource As Workbook, wbtarget As Workbook

'to get to the point for this question I have left out the folder picker subs

Sub SelectSourceandSearchforSheets()

wbsource.Activate

'activate and copy

Dim sourcesheet As Worksheet

Dim lastrow As String


For Each sourcesheet In Application.ActiveWorkbook.Worksheets
          
    Select Case CopyPaste
        Case Is = "apple"
            sourcesheet.Select
            
'copy column 1 source to column 1 target which is the apple copy method
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Copy

wbtarget.Worksheets("worksheet").Select
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastrow).Select
Selection.PasteSpecial
'etc
            
        Case Is = "banana"
            sourcesheet.Select

'copy column 2 source to column 1 target which is the banana copy method
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Copy

wbtarget.Worksheets("worksheet").Select
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastrow).Select
Selection.PasteSpecial
'etc

    End Select
    
    Next

End Sub

我需要帮助：

• 我不确定实现的循环是否循环遍历源工作簿的工作表以一一匹配 apple、babnana 等

• 我是否正确使用了“选择案例”功能，或者应该使用“如果那么”功能，还是其他功能？

• 我是否正确使用了“最后一行”功能将复制的数据放在工作表上的彼此下方？

Answer 1

过多使用选择/激活（请参阅此线程），如果可能的话最好根本不使用它。
选择案例需要比较的值，即

sourcesheet.Name

。但是，在您的情况下，似乎没有必要使用它，除非您对多张纸有类似的顺序，即“香蕉”与“胡萝卜”具有相同的列顺序。我将在我的代码示例中使用它。

对于最后一行，将一个用于源表（以避免选择问题），第二个用于目标表，并将其声明为 Long，而不是 String。当使用不同的工作表时，您还可以使用工作表变量来避免更多激活，即

sourcesheet.Range("A" & lastrow)

。

Option Explicit

Public wbsource As Workbook, wbtarget As Workbook

'to get to the point for this question I have left out the folder picker subs

Sub SelectSourceandSearchforSheets()
    
    Dim sourcesheet As Worksheet
    Dim lastrow As Long, lRowS As Long, i As Long
    Dim arr
    Dim targetSheet As Worksheet
    Set targetSheet = wbtarget.Worksheets("worksheet")
    Dim rngS As Range, rngD As Range
    For Each sourcesheet In wbsource.Worksheets
        Select Case sourcesheet.Name
            Case "apple", "carrot"
                arr = Array(4, 2, 1, 3, 5) 'order of columns
            Case "banana", "onion"
                arr = Array(1, 3, 2, 4, 5)
            Case Else
                GoTo skipNext
        End Select
        
        lRowS = sourcesheet.Cells(sourcesheet.Rows.Count, "A").End(xlUp).Row
        lastrow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
        If lRowS > 1 Then 'in case there's no data below the "ColumnX"-row
            For i = 0 To UBound(arr)
                Set rngS = sourcesheet.Range(sourcesheet.Cells(2, arr(i)), sourcesheet.Cells(lRowS, arr(i)))
                Set rngD = targetSheet.Range("A" & lastrow).Resize(lRowS - 1).Offset(, i)
                rngD.Value = rngS.Value 'no need for copy paste in your case
                'you could instantly pass over the values without setting the variables but that'd be less easy to read
            Next i
        End If
skipNext:
    Next sourcesheet

End Sub

希望有帮助！