Excel VBA: copying ranges, single cells to another workbook

Question

I am working on a simple VBA code for several templates, all with the same structure. From these templates (name: "Workbook1" e.g.), from "Profile" worksheet I would like to copy several cells: F6-F11, D15, F15, H15 and K30-38 to another workbook ("Tracker", "Sheet1) always to the first free row starting from C2 then C3 and so on. Could you please help me with that? I have the code for opening the given file:

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

There is quite a lot of workbooks. What is the name of the wb workbook? What is the name of the workbook containing this code? What do you need to be copied? Values, formulas, and/or formats? — VBasic2008
The source of the data (where I want to copy from): Workbook1(workbook), Profile, F6-F11, D15, F15, H15 and K30-38 to Tracker(workbook) , Sheet1, first available row starting from column C — Domosz
But what about workbook wb? Is it Workbook1 or...? Is the code in a third workbook? — VBasic2008

VBasic2008 VBasic2008 · Accepted Answer · 2021-02-16T16:10:31

Copy Non-Contiguous Range

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

Excel VBA: copying ranges, single cells to another workbook

1 Answers

Copy Non-Contiguous Range