2つの異なるシートの列を1つのシートにコピーする方法

Question

私は仕事をしており、Sheet1とSheet2の特定の列をSheet3にコピーする必要があります。

データがコピーされるはずのシートは、行14から始まります。また、Sheet1と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 

基本的には、シートの最後の行からデータの最後のビットまで（物理的には移動しませんが、位置を計算します）、列は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