将工作表 1 中 A + AC 中的所有单元格复制到工作表 3，然后删除工作表 1 中的行

Question

我目前正在使用以下代码根据 J 列中的值将代码复制到两个不同的工作表。

如果 J 中的值是 "ENDED-LOCATION"，我正在将单元格 A 的值复制到 AC 到工作表 3，我怎样才能写得更漂亮？我还想在复制完成后删除 Sheet1 中的行。我能做些什么来管理它？

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Main As Worksheet, Secondary As Worksheet, Third As Worksheet
Dim iCell As Range, FoundRange As Range, FoundRange2 As Range
Dim lRow As Long, NextRow As Long

'   Define worksheets for simplicity
With ThisWorkbook
    Set Main = .Worksheets("Sheet1")
    Set Secondary = .Worksheets("Sheet2")
    Set Third = .Worksheets("Sheet3")
End With

'   Calculate last row on Sheet2 (by column "A")
lRow = Secondary.Range("A" & Secondary.Rows.Count).End(xlUp).Row

'   Calculate last row on Sheet3 (by column "A")
NextRow = Third.Range("A" & Secondary.Rows.Count).End(xlUp).Row

'   Check if changes were made in columns "J" (Information)
'   If changes weren't made in column "J" leave this sub
If Intersect(Target, Main.Columns("J")) Is Nothing Then Exit Sub

'   Loop through each changed cell of column "J"
For Each iCell In Intersect(Target, Main.Columns("J")).Cells
    '   Find location on Sheet2
    'Main.Range("A" & iCell.Row).Value
    Set FoundRange = Secondary.Range("A2:A" & lRow).Find(Main.Range("A" & iCell.Row).Value, , xlValues, xlWhole)
    Set FoundRange2 = Third.Range("A2:A" & NextRow).Find(Main.Range("A" & iCell.Row).Value, , xlValues, xlWhole)
    '   If value of the changed cell is "NEW-LOCATION"..
    If iCell.Value = "NEW-LOCATION" Then
        '   And it didn't find this location on Sheet2..
        If FoundRange Is Nothing Then
            '   Add new location
            Secondary.Range("A" & lRow + 1).Value = Main.Range("A" & iCell.Row).Value
            Secondary.Range("B" & lRow + 1 & ":D" & lRow + 1 & "").Value = Main.Range("C" & iCell.Row & ":E" & iCell.Row & "").Value
            lRow = lRow + 1
        End If
    '   If value of the changed cell is "ENDED-LOCATION".
    ElseIf iCell.Value = "ENDED-LOCATION" Then
            '   Add new location
        '   And it didn't find this location on Sheet3..
        If FoundRange2 Is Nothing Then
            Third.Range("A" & NextRow + 1).Value = Main.Range("A" & iCell.Row).Value
            Third.Range("B" & NextRow + 1).Value = Main.Range("B" & iCell.Row).Value
            Third.Range("C" & NextRow + 1).Value = Main.Range("C" & iCell.Row).Value
            Third.Range("D" & NextRow + 1).Value = Main.Range("D" & iCell.Row).Value
            Third.Range("E" & NextRow + 1).Value = Main.Range("E" & iCell.Row).Value
            Third.Range("F" & NextRow + 1).Value = Main.Range("F" & iCell.Row).Value
            Third.Range("G" & NextRow + 1).Value = Main.Range("G" & iCell.Row).Value
            Third.Range("H" & NextRow + 1).Value = Main.Range("H" & iCell.Row).Value
            Third.Range("I" & NextRow + 1).Value = Main.Range("I" & iCell.Row).Value
            Third.Range("J" & NextRow + 1).Value = Main.Range("J" & iCell.Row).Value
            Third.Range("K" & NextRow + 1).Value = Main.Range("K" & iCell.Row).Value
            Third.Range("L" & NextRow + 1).Value = Main.Range("L" & iCell.Row).Value
            Third.Range("M" & NextRow + 1).Value = Main.Range("M" & iCell.Row).Value
            Third.Range("N" & NextRow + 1).Value = Main.Range("N" & iCell.Row).Value
            Third.Range("O" & NextRow + 1).Value = Main.Range("O" & iCell.Row).Value
            Third.Range("P" & NextRow + 1).Value = Main.Range("P" & iCell.Row).Value
            Third.Range("Q" & NextRow + 1).Value = Main.Range("Q" & iCell.Row).Value
            Third.Range("R" & NextRow + 1).Value = Main.Range("R" & iCell.Row).Value
            Third.Range("S" & NextRow + 1).Value = Main.Range("S" & iCell.Row).Value
            Third.Range("T" & NextRow + 1).Value = Main.Range("T" & iCell.Row).Value
            Third.Range("U" & NextRow + 1).Value = Main.Range("U" & iCell.Row).Value
            Third.Range("V" & NextRow + 1).Value = Main.Range("V" & iCell.Row).Value
            Third.Range("W" & NextRow + 1).Value = Main.Range("W" & iCell.Row).Value
            Third.Range("X" & NextRow + 1).Value = Main.Range("X" & iCell.Row).Value
            Third.Range("Y" & NextRow + 1).Value = Main.Range("Y" & iCell.Row).Value
            Third.Range("Z" & NextRow + 1).Value = Main.Range("Z" & iCell.Row).Value
            Third.Range("AA" & NextRow + 1).Value = Main.Range("AA" & iCell.Row).Value
            Third.Range("AB" & NextRow + 1).Value = Main.Range("AB" & iCell.Row).Value
            Third.Range("AC" & NextRow + 1).Value = Main.Range("AC" & iCell.Row).Value
            NextRow = NextRow + 1
        End If
    '   If value of the changed cell is NOT "NEW-LOCATION"..
    Else
        '   And it found this location in Sheet2..
        If Not FoundRange Is Nothing Then
            '   Delete row with this location
            FoundRange.EntireRow.Delete
            lRow = lRow - 1
        End If
    End If
Next
End Sub

Answer 1

尝试使用 .AutoFilter。

Sub CopyExpired()

    With Worksheets("sheet1")
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Cells(1, "A").CurrentRegion
            .AutoFilter field:=10, Criteria1:="ENDED-LOCATION"
            With .Resize(.Rows.Count - 1, 29).Offset(1, 0)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    .SpecialCells(xlCellTypeVisible).Copy _
                        Destination:=Worksheets("sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    .SpecialCells(xlCellTypeVisible).entirerow.delete
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

End Sub

将工作表 1 中 A + AC 中的所有单元格复制到工作表 3，然后删除工作表 1 中的行

Copy All cells from A + AC in sheet1 to Sheet3 then delete row in Sheet1

excel

vba

copy-paste

delete-row