How to select and copy a range of nonconsecutive columns with VBA

[k10riley]

Hi there,

I have some vba code where I am consolidating information from a series of workbooks into one page in another. However, I need to copy specifically Columns B, C, and G from Row 12 into one workbook where B, C, and G will be pasted into B, C, and D starting row 12. See the code below:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    'location of workbooks you wish to consolidate information from
    Const strPath As String = "C:\2021 Survey\2020 Responses\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
        'change .sheets("insert sheet name of sheet to be copied per workbook").cells.find
            LastRow = .Sheets("2020 Response").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        'Change .Sheets("Insert Sheet Name of sheet to be copied per workbook").Range("Insert range to copy data" & LastRow) ... etc
        'The name of the sheet destination for copied data is located in wkbDest.Sheets("Input sheet name").Cells(rows.counts, "Insert where to paste copied data").End .... etc


'****** It is specifically here where I am stuck. I'm not sure how to get this portion to capture column G as well. It works great currently, but I'm missing the G column data*****

            .Sheets("2020 Response").Range("B12:C" & LastRow).Copy wkbDest.Sheets("2020 Consolidated Responses").Cells(rows.count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Additionally, I wanted to be able to clear the previous contents every time I run the code, but only clear B, C, and D in the "2020 Consolidated Responses." I had previously added some code with ClearContents but I end up erasing the entire sheet.

Thanks so much for your assistance!

This code should be attributed to these forums, I was able to get this great code to begin with thanks to mumps!

 

[k10riley]

Wait! I determined it's because the workbook is blank! My assumption is I need to add a condition to ignore if the sheet is blank?

 

[Fluff]

If you have blank sheets try

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    'location of workbooks you wish to consolidate information from
    Const strPath As String = "C:\2021 Survey\2020 Responses\"
    ChDir strPath
   
    wkbDest.Sheets("2020 Consolidated Responses").Range("B12:D" & Rows.Count - 100).ClearContents
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
        'change .sheets("insert sheet name of sheet to be copied per workbook").cells.find
            LastRow = .Sheets("2020 Response").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If LastRow > 11 Then
               .Sheets("2020 Response").Range("B12:C" & LastRow & ",G12:G" & LastRow).Copy wkbDest.Sheets("2020 Consolidated Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            End If
             .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[k10riley]

If you have blank sheets try

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    'location of workbooks you wish to consolidate information from
    Const strPath As String = "C:\2021 Survey\2020 Responses\"
    ChDir strPath
   
    wkbDest.Sheets("2020 Consolidated Responses").Range("B12:D" & Rows.Count - 100).ClearContents
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
        'change .sheets("insert sheet name of sheet to be copied per workbook").cells.find
            LastRow = .Sheets("2020 Response").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If LastRow > 11 Then
               .Sheets("2020 Response").Range("B12:C" & LastRow & ",G12:G" & LastRow).Copy wkbDest.Sheets("2020 Consolidated Responses").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
               .Close savechanges:=False
            End If
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Absolutely amazing!! This works PERFECT. Except it opens up the workbook with the blank data?

 

[Fluff]

Move the .Close line after the End If

I have edited the code in post#12 to include this change

 

[k10riley]

Move the .Close line after the End If

Thank you so much! This is awesome!

 

[Fluff]

Glad to help & thanks for the feedback.