Excel VBA：将范围，单个单元格复制到另一个工作簿

Question

我正在为几个具有相同结构的模板编写一个简单的 VBA 代码。从这些模板（名称：“Workbook1”例如），从“Profile”工作表中，我想复制几个单元格：F6-F11、D15、F15、H15 和 K30-38 到另一个工作簿（“Tracker”、“Sheet1”）到从 C2 开始的第一个空闲行，然后是 C3 等等。你能帮我吗？我有打开给定文件的代码：

Option Explicit

Public Sub CopyData()

    Dim wb As Workbook
    Dim FileName As String

    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        If .Show Then
            FileName = .SelectedItems(1)
            Set wb = Workbooks.Open(FileName:=FileName)
            Workbooks("Workbook1").Worksheets("Profile").Range("F6:F11").Copy
            Workbooks("Tracker.xlsx").Worksheets("Sheet1").Range("C2").PasteSpecial Transpose:=True
            wb.Close SaveChanges:=False
            Set wb = Nothing
        End If
    End With

End Sub

Answer 1

复制非连续范围

Option Explicit

Sub copyData()

    ' Constants
    Const sRangesList As String = "F6:F11,D15,F15,H15,K30:K38"
    
    ' Source
    Dim FilePath As String
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        If .Show Then
            FilePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Dim swb As Workbook: Set swb = Workbooks.Open(FileName:=FilePath)
    Dim sws As Worksheet: Set sws = swb.Worksheets("Profile")
    Dim sRanges() As String: sRanges = Split(sRangesList, ",")
    
    ' Destination
    Dim dwb As Workbook: Set dwb = Workbooks("Tracker.xlsx")
    Dim dws As Worksheet: Set dws = dwb.Worksheets("Sheet1")
    Dim dInit As Range
    Set dInit = dws.Cells(dws.Rows.Count, "C").End(xlUp).Offset(1)
    Dim dCell As Range: Set dCell = dInit
    
    ' Copy/Paste
    Dim sRange As Range
    Dim n As Long
    Application.ScreenUpdating = False
    For n = 0 To UBound(sRanges)
        Set sRange = sws.Range(sRanges(n))
        sRange.Copy
        dCell.PasteSpecial Transpose:=True
        Set dCell = dCell.Offset(, sRange.Rows.Count)
    Next n
    
    ' Close/Save
    Application.CutCopyMode = False
    swb.Close SaveChanges:=False
    dws.Activate
    dInit.Offset(1).Activate
    'dwb.Save
    
End Sub