Question

我正在处理一项任务，我需要将Sheet1和Sheet2中的特定列复制到Sheet3中。

应该复制数据的工作表从第14行开始.Pheet1和Sheet2的数据长度也不同。

我已经找到了一种方法将数据从Sheet1复制到sheet3（通过研究）。问题是当我尝试将数据从sheet2复制到sheet3时，我的代码只会覆盖从sheet1复制的sheet3中的数据。

我希望我的代码将数据从sheet2复制到sheet3，并将其直接放在从sheet1复制的数据下面。并且由于来自sheet1的数据可能会有所不同（它可能包含0行或100行）。

Sub copyDataFromTwoSheetsIntoOneSheet()

With Sheets("Sheet1")
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("B14:O" & LR).AutoFilter Field:=14, Criteria1:="<>"

If LR > 1 Then
    .Range("B14:B" & LR).Copy
    Sheets("Sheet3").Range("B14").PasteSpecial xlPasteValues

    .Range("C14:C" & LR).Copy
    Sheets("Sheet3").Range("C14").PasteSpecial xlPasteValues

    .Range("D14:D" & LR).Copy
    Sheets("Sheet3").Range("D14").PasteSpecial xlPasteValues

    .Range("E14:E" & LR).Copy
    Sheets("Sheet3").Range("E14").PasteSpecial xlPasteValues

    .Range("F14:F" & LR).Copy
    Sheets("Sheet3").Range("F14").PasteSpecial xlPasteValues

    .Range("G14:G" & LR).Copy
    Sheets("Sheet3").Range("G14").PasteSpecial xlPasteValues

    .Range("H14:H" & LR).Copy
    Sheets("Sheet3").Range("H14").PasteSpecial xlPasteValues

    .Range("I14:I" & LR).Copy
    Sheets("Sheet3").Range("I14").PasteSpecial xlPasteValues

    .Range("J14:J" & LR).Copy
    Sheets("Sheet3").Range("J14").PasteSpecial xlPasteValues

    .Range("O14:O" & LR).Copy
    Sheets("Sheet3").Range("N14").PasteSpecial xlPasteValues

End If
.AutoFilterMode = False
End With

With Sheets("Sheet2")
.AutoFilterMode = False
LR = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("B14:M" & LR).AutoFilter Field:=12, Criteria1:="<>"


If LR > 1 Then

    .Range("B14:B" & LR).Copy
    Sheets("Sheet3").Range("B14").PasteSpecial xlPasteValues

    .Range("C14:C" & LR).Copy
    Sheets("Sheet3").Range("C14").PasteSpecial xlPasteValues

    .Range("D14:D" & LR).Copy
    Sheets("Sheet3").Range("D14").PasteSpecial xlPasteValues

    .Range("E14:E" & LR).Copy
    Sheets("Sheet3").Range("E14").PasteSpecial xlPasteValues

    .Range("F14:F" & LR).Copy
    Sheets("Sheet3").Range("F14").PasteSpecial xlPasteValues

    .Range("G14:G" & LR).Copy
    Sheets("Sheet3").Range("G14").PasteSpecial xlPasteValues

    .Range("H14:H" & LR).Copy
    Sheets("Sheet3").Range("H14").PasteSpecial xlPasteValues

    .Range("I14:I" & LR).Copy
    Sheets("Sheet3").Range("I14").PasteSpecial xlPasteValues

    .Range("J14:J" & LR).Copy
    Sheets("Sheet3").Range("J14").PasteSpecial xlPasteValues

    .Range("M14:M" & LR).Copy
    Sheets("Sheet3").Range("N14").PasteSpecial xlPasteValues

End If
.AutoFilterMode = False

End Sub

Answer 1

首先，

.Range("B14:B" & LR).Copy
Sheets("Sheet3").Range("B14").PasteSpecial xlPasteValues

.Range("C14:C" & LR).Copy
Sheets("Sheet3").Range("C14").PasteSpecial xlPasteValues

.Range("D14:D" & LR).Copy
Sheets("Sheet3").Range("D14").PasteSpecial xlPasteValues

.Range("E14:E" & LR).Copy
Sheets("Sheet3").Range("E14").PasteSpecial xlPasteValues

.Range("F14:F" & LR).Copy
Sheets("Sheet3").Range("F14").PasteSpecial xlPasteValues

.Range("G14:G" & LR).Copy
Sheets("Sheet3").Range("G14").PasteSpecial xlPasteValues

.Range("H14:H" & LR).Copy
Sheets("Sheet3").Range("H14").PasteSpecial xlPasteValues

.Range("I14:I" & LR).Copy
Sheets("Sheet3").Range("I14").PasteSpecial xlPasteValues

.Range("J14:J" & LR).Copy
Sheets("Sheet3").Range("J14").PasteSpecial xlPasteValues

可以浓缩为：

.Range("B14:J" & LR).Copy
Sheets("Sheet3").Range("B14").PasteSpecial xlPasteValues

因为它是一个连续的范围

对于最后一个数据点以下的粘贴，您可以使用以下内容：

Sheets("Sheet3").Range("B" & rows.count).end(xlup).offset(1,0).PasteSpecial xlPasteValues

基本上，它在B列中从表格的最后一行上升到最后一位数据（没有物理移动但计算出位置），然后它偏移了1行（换句话说，最后一位数据下方1个单元格）

你也可以循环第1页和第2页，这样你只需要编写一次代码，不需要重复（我冒昧地为你声明你的LR变量）。

Sub copyDataFromTwoSheetsIntoOneSheet()
Dim X As Long, LR As Long, PasteRow As Long
For X = 1 To 2
    With Sheets("Sheet" & X)
    .AutoFilterMode = False
    LR = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B14:O" & LR).AutoFilter Field:=14, Criteria1:="<>"
    If LR > 1 Then
        PasteRow = Sheets("Sheet3").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row
        .Range("B14:J" & LR).Copy
        Sheets("Sheet3").Range("B" & PasteRow).PasteSpecial xlPasteValues
        If X = 1 Then
            .Range("O14:O" & LR).Copy
        Else
            .Range("M14:M" & LR).Copy
        End If
        Sheets("Sheet3").Range("N" & PasteRow).PasteSpecial xlPasteValues
    End If
    .AutoFilterMode = False
    End With
Next
End Sub

Answer 2

您可以按如下方式重构代码：

Option Explicit

Sub copyDataFromTwoSheetsIntoOneSheet()
    Dim nFiltered As Long

    With Sheets("Sheet1")
        .AutoFilterMode = False
        With .Range("O14", .Cells(.Rows.count, "B").End(xlUp))
            .AutoFilter Field:=14, Criteria1:="<>"
            nFiltered = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 '<--| count filtered cells excluding header row
            If nFiltered > 0 Then CopyFiltered .Cells, 0, 0, 9, 13, 1, 14
        End With
        .AutoFilterMode = False
    End With

    With Sheets("Sheet2")
        .AutoFilterMode = False
        With .Range("M14", .Cells(.Rows.count, "B").End(xlUp))
            .AutoFilter Field:=12, Criteria1:="<>"
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then CopyFiltered .Cells, IIf(nFiltered > 0, 1, 0), 0, 9, 11, 1, 14
        End With
        .AutoFilterMode = False
    End With
End Sub


Sub CopyFiltered(rng As Range, rowsReduction As Long, firstColumnOffset As Long, firstColumnResize As Long, secondColumnOffset As Long, secondColumnResize As Long, pasteSheetColumnToFindLastRowIn As Long)
    Dim lastRow As Long

    lastRow = WorksheetFunction.Max(14, Sheets("Sheet3").Cells(Rows.count, pasteSheetColumnToFindLastRowIn).End(xlUp).Offset(1).Row) '<--| get Sheet3 passed column row to start pasting from

    With rng.Resize(rng.Rows.count - rowsReduction).Offset(rowsReduction)
        .Offset(, firstColumnOffset).Resize(, firstColumnResize).SpecialCells(xlCellTypeVisible).Copy
        Sheets("Sheet3").Range("B" & lastRow).PasteSpecial xlPasteValues
        Application.CutCopyMode = False

        .Offset(, secondColumnOffset).Resize(, secondColumnResize).SpecialCells(xlCellTypeVisible).Copy
        Sheets("Sheet3").Range("N" & lastRow).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End With
End Sub

如何将两个不同工作表中的列复制到一个工作表中

2 个答案: