Question

我想在行H中找到单词FLAG时复制行A-E，并且我想跳过未找到Flag的所有行。下面是我正在使用的表的示例以及我希望结果表看起来像什么。

这是我的代码，但它没有复制具有Flag的行A-E，它只是将前三行复制到新工作表。

Sub foo()
    Dim ws As Worksheet: Set ws = Sheets("Duration")
    Dim wsResult As Worksheet: Set wsResult = Sheets("Report")

    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    For i = 3 To LastRow 
        For x = 8 To 8 
            If ws.Cells(i, x) = "FLAG" Then 
                NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1
                ws.Range("A" & i & ":C" & i).Copy  
                wsResult.Range("A" & NextFreeRow).PasteSpecial xlPasteAll 
                ws.Cells(i, x - 4).Copy 
                wsResult.Cells(NextFreeRow, 4).PasteSpecial xlPasteAll
                ws.Cells(i,x-3).Copy
                wsResult.Cells(NextFreeRow, 5).PasteSpecial xlPasteAll
            End If
        Next x
    Next i
End Sub

任何帮助将不胜感激！

Answer 1

如果你想改变从A到C到A到E的复制，那么这样就可以了：

Sub foo()

Dim ws As Worksheet: Set ws = Sheets("Duration")
Dim wsResult As Worksheet: Set wsResult = Sheets("Report")

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
        If ws.Cells(i, 8) = "FLAG" Then
            NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1
            ws.Range("A" & i & ":E" & i).Copy Destination:=wsResult.Range("A" & NextFreeRow)
            'the code below will have to be amended if you changed your table's layout and you also want some other cells copied as well as A to E
            'ws.Cells(i, 4).Copy
            'wsResult.Cells(NextFreeRow, 6).PasteSpecial xlPasteAll
            'ws.Cells(i, 5).Copy
            'wsResult.Cells(NextFreeRow, 7).PasteSpecial xlPasteAll
        End If
Next i
End Sub

Answer 2

如果你必须复制工作表“持续时间”列AE行，其对应的列H单元格值为“Flag”并将它们粘贴到工作表“报告”列AE开始形式的最后一个非空单元格A列，然后像这样（评论中的解释）：

Option Explicit

Sub foo()
    Dim wsResult As Worksheet: Set wsResult = Sheets("Report")

    With Worksheets("Duration")
        With .Range("A2:H" & .Cells(.Rows.Count, "A").End(xlUp).Row) 'reference its columns A:H cells from row 2 (header) down to last not empty one in column "A"
            .AutoFilter field:=8, Criteria1:="FLAG" ' filter referenced cells on 8thd column "FLAG" content
            If Application.WorksheetFunction.Subtotal(103, .Columns(8)) > 1 Then .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible).Copy Destination:=wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Offset(1) ' if any filtered cell other than the header then copy their first five columns and paste to 'wsResult' sheet starting from its column A last not empty cell
        End With
        .AutoFilterMode = False
    End With
End Sub

在单元格中查找特定单词并将其旁边的行复制到另一个工作表

2 个答案: