CODEWITHSUNDEEP
vbaexcel
barooon gara
barooon gara

Reputation: 123

Copy Union of multiple columns from one sheet to another

I wrote a code to copy Column D, H, M and paste it on a brand new sheet starting from A-C. I first find the last row , after that I Union the 3 column range together then select the sheet and paste it.

For some reason I don't understand why it does not work. I have never used Union range before so not sure if that is the problem, or if it is something like my for loop. Help would be appreciated.

Dim ws As Worksheet
Dim lastRow As Integer

'for loop variables
Dim transCounter As Integer
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim multipleRange As Range
Dim lastRow1 As Integer
Dim ittercell As Integer

Set ws = ActiveSheet


For transCounter = 1 To 10

    r.AutoFilter Field:=6, Criteria1:=transCounter.Value, Operator:=xlFilterValues

    With Application.ActiveSheet
        lastRow1 = .Cells(.Rows.Count, "AE").End(xlUp).Row
    End With

    Set range1 = Sheets("Sheet1").Range("D6:D" & lastRow1).SpecialCells(xlCellTypeVisible)
    Set range2 = Sheets("Sheet1").Range("H6:I" & lastRow1).SpecialCells(xlCellTypeVisible)
    Set range3 = Sheets("Sheet1").Range("M6:M" & lastRow1).SpecialCells(xlCellTypeVisible)

    Set multipleRange = Union(range1, range2, range3)

    multipleRange.Copy

    Sheets("O1 Filteration").Select

    'Range("A3").Select
    'Range("A3").PasteSpecial xlPasteValues
    ittercell = 1
    Cells(3, ittercell).PasteSpecial xlPasteValues

    ittercell = ittercell + 6

Next transCounter

Upvotes: 1

Views: 1358

Answers (1)

Robin Mackenzie
Robin Mackenzie

Reputation: 19319

There's a couple of issues with your code that might be causing the fault:

  • r is not defined in your code
  • use of transCounter.Value instead of just CStr(transCounter) (see @QHarr comment)
  • iterCell reset every iteration of the loop (see @QHarr comment)
  • Combination of ActiveSheet, unqualified Cells(... and manual Select on sheets makes the Range qualifications ambiguous

However, I do think the main logic of using Union, then Copy, then PasteSpecial is OK and just some tweaking is required.

Here is some working code where you update the Worksheet and Range references with your own. Please follow the comments.

Option Explicit

Sub CopyUnionColumns()

    Dim wsSource As Worksheet '<-- Sheet1 in your code
    Dim wsTarget As Worksheet '<-- O1 Filteration in your code
    Dim rngFilter As Range '<-- main data range on Sheet1
    Dim rngSource As Range '<-- to hold Union'd data after filtering
    Dim rngTarget As Range '<-- range in O1 Filteration to paste code to
    Dim lngLastRow As Long '<-- last row of main data
    Dim lngCounter As Long '<-- loop variable
    Dim lngPasteOffsetCol As Long '<-- offset column for pasting in the loop

    ' set references to source and target worksheets
    Set wsSource = ThisWorkbook.Worksheets("Sheet2") '<-- update for your workbook
    Set wsTarget = ThisWorkbook.Worksheets("Sheet3") '<-- update for your workbook

    ' set reference to data for filtering in source worksheet
    lngLastRow = wsSource.Cells(wsSource.Rows.Count, 6).End(xlUp).Row
    Set rngFilter = wsSource.Range("A1:F" & lngLastRow)

    ' initialise offset column
    lngPasteOffsetCol = 0

    ' iterate rows
    For lngCounter = 1 To 10

        ' filter data the data per the counter
        rngFilter.AutoFilter Field:=6, Criteria1:=CStr(lngCounter), Operator:=xlFilterValues

        ' set source range as union of columnar data per last row
        Set rngSource = Application.Union( _
            wsSource.Range("A1:A" & lngLastRow).SpecialCells(xlCellTypeVisible), _
            wsSource.Range("C1:C" & lngLastRow).SpecialCells(xlCellTypeVisible), _
            wsSource.Range("E1:E" & lngLastRow).SpecialCells(xlCellTypeVisible))

        ' set target range on target sheet top left cell and offset column
        Set rngTarget = wsTarget.Range("A1").Offset(0, lngPasteOffsetCol)

        ' copy source cells
        rngSource.Copy

        ' paste to target
        rngTarget.PasteSpecial Paste:=xlPasteAll

        ' increment offset
        lngPasteOffsetCol = lngPasteOffsetCol + 6

    Next lngCounter

    ' cancel cut copy mode
    Application.CutCopyMode = False

    ' cancel autofilter
    wsSource.AutoFilterMode = False

End Sub

Upvotes: 1

Related Questions