Question

我写了一个代码来复制D，H，M并将其粘贴在一个从A-C开始的全新表格上。我首先找到最后一行，然后我将Union 3列范围放在一起，然后选择工作表并粘贴它。

出于某种原因，我不明白为什么它不起作用。我以前从未使用Union范围，因此不确定这是否是问题，或者它是否类似于我的for循环。帮助将不胜感激。

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

Answer 1

您的代码存在一些可能导致错误的问题：

r未在您的代码中定义
使用transCounter.Value代替CStr(transCounter)（请参阅@QHarr评论）
iterCell重置循环的每次迭代（参见@QHarr comment）
工作表上ActiveSheet，不合格Cells(...和手动Select的组合会使Range资格模糊不清

但是，我认为使用Union，然后Copy，然后PasteSpecial的主要逻辑是正常的，只需要进行一些调整。

以下是一些工作代码，您可以使用自己的代码更新Worksheet和Range引用。请关注评论。

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

将多个列的联合从一个工作表复制到另一个工作表

1 个答案: