☰

多个宏代码的编写

tag-icon • tag-icon microsoft-excel worksheet-function macros
多个宏代码的编写

我创建了一个电子表格，其中有一个宏，当 A 列中的状态标记为“已付款”时，该宏将删除一行并将其移动到新选项卡。我需要更进一步，以便如果状态标记为“已付款”并且 D 列中的发票号与同一行匹配，则所有相同的发票号也将移动到新选项卡。我使用的代码如下。图像是电子表格的片段。在示例中，Sarah Phillips 在第 9-12 行中有数据，A 列第 9 行中的状态为“已付款”。我需要将具有相同发票号的所有 4 个移动到新电子表格。在此处输入图片描述

Sub TransferData()

    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "paid" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "paid" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

答案1

If CStr(xRg(K).Value) = "paid" Then捕获该行的发票号码后，for在第一个循环内再执行一次循环，循环遍历所有行并移动所有与发票号码匹配的行。

编辑：看起来这个方法可行。测试（在数据副本上）并根据需要进行更改。

Sub TransferData()

    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    ' added:
    Dim invNo As Long

    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "paid" Then
            ' added:
            invNo = xRg(K).Offset(0, 3).Value2
            For L = 1 To xRg.Count
                If xRg(L).Offset(0, 3).Value2 = invNo Then
                xRg(L).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
                xRg(L).EntireRow.Delete
                If xRg(L).Offset(0, 3).Value2 = invNo Then
                    L = L - 1
                End If
                J = J + 1
                End If
            Next
            If CStr(xRg(K).Value) = "paid" Then
               K = K - 1
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

相关内容