Question

我想遍历D列，如果有一个“是”，请复制许多与D列中的“是”的单元格保持相同距离的单元格。

例如，如果D23说“是”，则将A23，A24，B22和E22并排复制到另一张纸上。

我记录了以下代码。我将宏附加到按钮上。如果我滚动到D列中具有“是”的单元格，然后单击该按钮，它将满足我的要求。我不知道如何在整个D列中单独运行代码。

此外，它粘贴在信息的侧面。有没有一种方法可以将新的工作表粘贴到以前粘贴的数据下面，因为当前行之间有很多空白，因为“是”仅每20行左右出现一次。

Sub Test()  
 ' Test Macro

Range("A23").Select
Selection.Copy
Range("V23").Select
ActiveSheet.Paste
Range("A24").Select
Application.CutCopyMode = False
Selection.Copy
Range("W23").Select
ActiveSheet.Paste
Range("B22").Select
Application.CutCopyMode = False
Selection.Copy
Range("Y23").Select
ActiveSheet.Paste
Range("E22").Select
Application.CutCopyMode = False
Selection.Copy
Range("Z23").Select
ActiveSheet.Paste  

End Sub

Answer 1

因为您至少尝试过，所以建议以下内容。

有一个For循环可遍历所有包含数据的行，并检查是否为“是”。如果有，则将数据复制到目标工作表中。

Option Explicit

Public Sub FindKeywordAndCopyData()
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Data") 'define data sheet

    Dim wsDestination As Worksheet
    Set wsDestination = ThisWorkbook.Worksheets("Output") 'define output sheet

    Dim LastRow As Long
    LastRow = wsSource.Cells(Rows.Count, "D").End(xlUp).Row 'find last used row in column D

    Dim NextFreeRow As Long

    Dim iRow As Long
    For iRow = 2 To LastRow 'loop through all data rows (from row 2 to last used row)
        If wsSource.Cells(iRow, "D").Value = "yes" Then 'check if column D has a "yes"
            With wsDestination
                NextFreeRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 'find next empty row in destination sheet

                'copy the cell values to destination A, B, C, D
                .Cells(NextFreeRow, "A").Value = wsSource.Cells(iRow, "A").Value     'current row column A
                .Cells(NextFreeRow, "B").Value = wsSource.Cells(iRow + 1, "A").Value 'next row column A
                .Cells(NextFreeRow, "C").Value = wsSource.Cells(iRow - 1, "B").Value 'previous row column B
                .Cells(NextFreeRow, "D").Value = wsSource.Cells(iRow - 1, "E").Value 'previous row column E
            End With
        End If
    Next iRow
End Sub

如果满足某些条件，则在工作表之间复制数据

1 个答案: