Question

以下宏适用于-我有一本包含两张纸的工作簿（活动和存档）。在活动表中，我有AB列，其中包含活动或存档状态。如果其状态Archive宏被剪切，并将该行移至工作表Archive。此宏工作完美。

现在，我需要向Excel添加其他工作表并将其命名为“新”，“已接受”，“已拒绝”，当然我也将相同的状态添加到AB列中。现在，如果AB = Archive或New或Accepted或Rejected，我希望宏执行相同的操作，并将行移至名为Archive或New或Accepted或Rejected的工作表。我自己尝试过，但是做不到。

需要您的帮助。预先感谢。

Private Sub CommandButton1_Click()
    Dim x As Integer
    Dim y As Integer
    Dim i As Integer
    Dim shSource As Worksheet
    Dim shTarget1 As Worksheet

    Set shSource = ThisWorkbook.Sheets("Active")
    Set shTarget1 = ThisWorkbook.Sheets("Archive")

    If shTarget1.Cells(2, 28).Value = "" Then
        x = 2
    Else
        x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count + 1
    End If

    i = 2

    Do Until shSource.Cells(i, 28) = ""
        If shSource.Cells(i, 28).Value = "Archive" Then
            shSource.Rows(i).Copy
            shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
            shSource.Rows(i).Delete
            x = x + 1
            GoTo Line1
        End If
        i = i + 1
    Line1: Loop 
End Sub

Answer 1

您可以设置多个变量，并在选定的情况下选择合适的变量。这里有一些重复可以用数组清除。

    Sub CommandButton1_Click()

Dim x As Integer 'archive target counter
Dim y As Integer 'new target counter
Dim z As Integer 'accepted target counter
Dim w As Integer 'rejected target counter
'the above could be an array if we were trying to generalize

Dim i As Integer 'counts rows in original sheet
Dim shSource As Worksheet

Dim shTarget1 As Worksheet 'archive sheet
Dim shTarget2 As Worksheet 'new sheet
Dim shTarget3 As Worksheet 'accepted sheet
Dim shTarget4 As Worksheet 'rejected sheet
'these 4 could also be an array, as could their names, in which case some things become loops and the select case could be written out


Set shSource = ThisWorkbook.Sheets("Active")
Set shTarget1 = ThisWorkbook.Sheets("Archive")
Set shTarget2 = ThisWorkbook.Sheets("New")
Set shTarget3 = ThisWorkbook.Sheets("Accepted")
Set shTarget4 = ThisWorkbook.Sheets("Rejected")


If shTarget1.Cells(2, 28).Value = "" Then
x = 2
Else
x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If

If shTarget2.Cells(2, 28).Value = "" Then
y = 2
Else
y = shTarget2.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If

If shTarget3.Cells(2, 28).Value = "" Then
z = 2
Else
z = shTarget3.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If

If shTarget4.Cells(2, 28).Value = "" Then
w = 2
Else
w = shTarget4.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If


i = 2

Do Until shSource.Cells(i, 28) = ""
Select Case shSource.Cells(i, 28).Value
    Case "Archive":
        shSource.Rows(i).Copy
        shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
        shSource.Rows(i).Delete
        x = x + 1
    Case "New":
        shSource.Rows(i).Copy
        shTarget2.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
        shSource.Rows(i).Delete
        y = y + 1
    Case "Accepted":
        shSource.Rows(i).Copy
        shTarget3.Cells(z, 1).PasteSpecial Paste:=xlPasteValues
        shSource.Rows(i).Delete
        z = z + 1
    Case "Rejected":
        shSource.Rows(i).Copy
        shTarget4.Cells(w, 1).PasteSpecial Paste:=xlPasteValues
        shSource.Rows(i).Delete
        w = w + 1
    Case Else 'no cutting so move to next input line
        i = i + 1
End Select
Loop
End Sub

编辑：以下是基于数组的版本，其重复次数较少。另外，我发现我一直覆盖目标表中的第一行，因此在初始化目标计数器时，我在目标计数器上添加了2（而不是1）。如果原始文档在您的上下文中有效，则可以将其切换回原处。

Sub CommandButton1_Click()
Dim TargetCounters(3) As Integer
Dim TargetNames(3) As String
TargetNames(0) = "Archive"
TargetNames(1) = "New"
TargetNames(2) = "Accepted"
TargetNames(3) = "Rejected"

Dim i As Integer 'counts rows in original sheet
Dim shSource As Worksheet

Dim shTargets(3) As Worksheet

Set shSource = ThisWorkbook.Sheets("Active")

For i = 0 To 3
    Set shTargets(i) = ThisWorkbook.Sheets(TargetNames(i))
    If shTargets(i).Cells(2, 28).Value = "" Then
        TargetCounters(i) = 2
    Else 'there is stuff. Imagine for example it is in rows 2 to 7. Count will be 6. We need to start pasting in row 8
        TargetCounters(i) = shTargets(i).Cells(2, 28).CurrentRegion.Rows.Count + 2 'changed this from orinal + 1
    End If
    Next i

    i = 2
    Dim MatchIndex As Integer

    Do Until shSource.Cells(i, 28).Value = ""
'you could switch this case to a call on the application's match function against TargetNames
'if you take care with the case where it is not found and indexing being right and not off by 1
            Select Case shSource.Cells(i, 28).Value
            Case "Archive":
                MatchIndex = 0
            Case "New":
                MatchIndex = 1
            Case "Accepted":
                MatchIndex = 2
            Case "Rejected":
                MatchIndex = 3
            Case Else 'no cutting so set signal and we will move to next input line
                MatchIndex = -1
            End Select
            If (MatchIndex = -1) Then
                i = i + 1
            Else
                shSource.Rows(i).Copy
                shTargets(MatchIndex).Cells(TargetCounters(MatchIndex), 1).PasteSpecial Paste:=xlPasteValues
                shSource.Rows(i).Delete
                TargetCounters(MatchIndex) = TargetCounters(MatchIndex) + 1
            End If
        Loop
    End Sub

宏基于单元格值将行移动到另一张表

1 个答案: