首页 文章

VBA：使用条件选择行，然后指定列，通过（复制/粘贴）构建表

提问于
浏览 次
1

我想通过从另一个Excel工作表“效率”中提取数据，在一个Excel工作表“Ship”上构建一个表 . “效率”表上的行数据按“发货”，“离开”，“导入”和“导出”进行分类 . 每个类别（装运，休假，进口，出口）都有几个项目，它们没有特定的顺序 . “效率”表上的表占据A：H列，从第2行开始;长度可以变化 . 我希望能够在行中搜索“已发货”并复制匹配行的列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

结束子

excel vba excel-vba

2 回答

  • 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
    回复于
  • 0

    试试下面的代码

    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
    回复于

相关问题