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

2 回答

• 0

  对于初学者，

  .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
  

  回复于 2024-04-24T22:14:36+08:00
• 0

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

  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
  

  回复于 2024-04-24T22:14:36+08:00