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

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

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

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

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

twoSheetsTooneSheet（）的子副本数据
附页（“第1页”）
.AutoFilterMode=False
LR=.Range（“B”和.Rows.Count）.End（xlUp）.Row
.Range（“B14:O”和LR）。自动筛选字段：=14，标准1:=“”
如果LR>1，则
.范围（“B14:B”和LR）.复制
表（“表3”）。范围（“B14”）。粘贴特殊XLPaste值
.范围（“C14:C”和LR）.复制
表（“表3”）。范围（“C14”）。粘贴特殊XLPaste值
.范围（“D14:D”和LR）.复制
图纸（“图纸3”）.范围（“D14”）.粘贴特殊XLPaste值
.范围（“E14:E”和LR）.复制
表（“表3”）.范围（“E14”）.粘贴特殊XLPaste值
.范围（“F14:F”和LR）.复制
图纸（“图纸3”）.范围（“F14”）.粘贴特殊XLPaste值
.范围（“G14:G”和LR）.复制
板材（“板材3”）.范围（“G14”）.粘贴特殊XLPaste值
.范围（“H14:H”和LR）.复制
板材（“板材3”）.范围（“H14”）.粘贴特殊XLPaste值
.Range（“I14:I”和LR）。复制
图纸（“图纸3”）.范围（“I14”）.粘贴特殊XLPaste值
.范围（“J14:J”和LR）.副本
表（“表3”）.范围（“J14”）.粘贴特殊XLPaste值
.Range（“O14:O”和LR）。复制
板材（“板材3”）.范围（“N14”）.粘贴特殊XLPaste值
如果结束
.AutoFilterMode=False
以
附页（“第2页”）
.AutoFilterMode=False
LR=.Range（“B”和.Rows.Count）.End（xlUp）.Row
.Range（“B14:M”和LR）。自动筛选字段：=12，标准1:=“”
如果LR>1，则
.范围（“B14:B”和LR）.复制
表（“表3”）。范围（“B14”）。粘贴特殊XLPaste值
.范围（“C14:C”和LR）.复制
表（“表3”）。范围（“C14”）。粘贴特殊XLPaste值
.范围（“D14:D”和LR）.复制
图纸（“图纸3”）.范围（“D14”）.粘贴特殊XLPaste值
.范围（“E14:E”和LR）.复制
表（“表3”）.范围（“E14”）.粘贴特殊XLPaste值
.范围（“F14:F”和LR）.复制
图纸（“图纸3”）.范围（“F14”）.粘贴特殊XLPaste值
.范围（“G14:G”和LR）.复制
板材（“板材3”）.范围（“G14”）.粘贴特殊XLPaste值
.范围（“H14:H”和LR）.复制
板材（“板材3”）.范围（“H14”）.粘贴特殊XLPaste值
.Range（“I14:I”和LR）。复制
图纸（“图纸3”）.范围（“I14”）.粘贴特殊XLPaste值
.范围（“J14:J”和LR）.副本
表（“表3”）.范围（“J14”）.粘贴特殊XLPaste值
.范围（“M14:M”和LR）.复制
板材（“板材3”）.范围（“N14”）.粘贴特殊XLPaste值
如果结束
.AutoFilterMode=False
端接头

对于初学者

.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变量）

twoSheetsTooneSheet（）的子副本数据
尺寸X为长，LR为长，粘贴行为长
对于X=1到2
带图纸（“图纸”和X）
.AutoFilterMode=False
LR=.Range（“B”和.Rows.Count）.End（xlUp）.Row
.Range（“B14:O”和LR）。自动筛选字段：=14，标准1:=“”
如果LR>1，则
粘贴行=图纸（“Sheet3”）。范围（“B”和行数。计数）。结束（xlUp）。偏移量（1，0）。行
.范围（“B14:J”和LR）.复制
图纸（“Sheet3”）。范围（“B”和粘贴行）。粘贴特殊XLPasteValue
如果X=1，则
.Range（“O14:O”和LR）。复制
其他的
.范围（“M14:M”和LR）.复制
如果结束
图纸（“Sheet3”）。范围（“N”和粘贴行）。粘贴特殊XLPasteValue
如果结束
.AutoFilterMode=False
以
下一个
端接头

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

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

选项显式
子副本数据从两张图纸到一张图纸（）
模糊的，模糊的
附页（“第1页”）
.AutoFilterMode=False
带.Range（“O14”，.Cells（.Rows.count，“B”）.End（xlUp））
.自动筛选字段：=14，标准1:=“”
nFiltered=Application.WorksheetFunction.Subtotal（103，.Resize（，1））-1'0然后CopyFiltered.Cells，0,0,9,13,1,14
以
.AutoFilterMode=False
以
附页（“第2页”）
.AutoFilterMode=False
带.Range（“M14”，.Cells（.Rows.count，“B”）.End（xlUp））
.自动筛选字段：=12，标准1:=“”
如果Application.WorksheetFunction.Subtotal（103，.Cells）>1，那么CopyFiltered.Cells、IIf（nFiltered>0,1,0）、0,9,11,1,14
以
.AutoFilterMode=False
以
端接头
子CopyFiltered（rng为范围，行缩减为长度，firstColumnOffset为长度，firstColumnResize为长度，secondColumnOffset为长度，secondColumnResize为长度，PasseSheetColumnToFindLastRowin为长度）
最后一排一样长
lastRow=WorksheetFunction.Max（14，Sheets（“Sheet3”）.Cells（Rows.count，PasteSheetColumntToFindLastRowin）.End（xlUp）.Offset（1）.Row）“您提供的代码有效，但正在复制的数据似乎从第3000+行开始。我不知道它为什么那样做。谢谢你回答我的问题。我真的很感激。
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

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