VBA：行を選択するために条件を使用して特定の列を選択して（コピー/貼り付け）テーブルを作成する

Question

別のExcelシート「効率」からデータを引き出して、1つのExcelシート "船"にテーブルを作成します。 「効率」シートの行データは、「出荷」、「残し」、「インポート」および「エクスポート」によって分類されます。 各カテゴリ（出荷、離脱、インポート、エクスポート）にはいくつかの項目があり、特定の順序はありません。 「効率性」シートの表は列A：Hを占め、行2から始まります。長さは変わることがあります。 "Shipped"の行を検索し、一致する行の列A、D：F、Hをコピーして、 "Ship"シートのセルB4から貼り付けたいと思っています。誰も私を助けることができますか？

サブシップ（）

ActiveSheet.Range("$A$1:$H$201").AutoFilter Field:=4, Criteria1:="Shipped" 
' this is looking in a specific range, I want to make it more dynamic 

Range("A4:A109").Select 
'This is the range selected to copy, again I want to make this part more dynamic 

Application.CutCopyMode = False 
Selection.Copy 
Range("A4:A109,D4:F109,H4:H109").Select 
Range("G4").Activate 
Application.CutCopyMode = False 
Selection.Copy 
Sheets("Ship").Select 
Range("B4").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

End Subの

Answer 1

このコードは、あなたの質問に与えられるようにあなたの情報に基づいてテストされています。

Sub Ship() 

Dim wsEff As Worksheet 
Dim wsShip As Worksheet 

Set wsEff = Worksheets("Efficiency") 
Set wsShip = Worksheets("Shipped") 

With wsEff 

    Dim lRow As Long 
    'make it dynamic by always finding last row with data 
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

    'changed field to 2 based on your above comment that Shipped is in column B (the code you posted has 4). 
    .Range("A1:H" & lRow).AutoFilter Field:=2, Criteria1:="Shipped" 

    Dim rngCopy As Range 
    'only columns A, D:F, H 
    Set rngCopy = Union(.Columns("A"), .Columns("D:F"), .Columns("H")) 
    'filtered rows, not including header row - assumes row 1 is headers 
    Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible) 

    rngCopy.Copy 

End With 

wsShip.Range("B4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 


End Sub 

Answer 2

は、以下のコード

を試してみてください

Sub runthiscode() 
    Worksheets("Efficiency").Select 
    lastrow = Range("A" & Rows.Count).End(xlUp).Row 
    startingrow = 4 
    For i = 2 To lastrow 
     If Cells(i, 2) = "Shipped" Then 
      cella = Cells(i, 1) 
      celld = Cells(i, 4) 
      celle = Cells(i, 5) 
      cellf = Cells(i, 6) 
      cellh = Cells(i, 8) 
      Worksheets("Ship").Cells(startingrow, 2) = cella 
      Worksheets("Ship").Cells(startingrow, 5) = celld 
      Worksheets("Ship").Cells(startingrow, 6) = celle 
      Worksheets("Ship").Cells(startingrow, 7) = cellf 
      Worksheets("Ship").Cells(startingrow, 9) = cellh 
      startingrow = startingrow + 1 
     End If 
    Next i 
End Sub