VBA：通过（复制/粘贴）使用标准select行，然后指定列生成表格

我想通过从另一个excel表格“效率”中提取数据，在一张Excel表格“Ship”上build立一个表格。 “效率”表中的行数据按“发货”，“离开”，“导入”和“导出”分类。 每个类别（发货，出货，import，出口）都有几个项目，并没有特定的顺序。 “效率”表中的表占据A：H列，并从第2行开始; 长度可以变化。 我希望能够search“发货”行并复制匹配行的列A，D：F和H，并将其粘贴在“发运”工作表的单元格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 

结束小组

Answer 1

此代码已根据您在问题中提供的信息进行了testing：

 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