宏基於單元格值將行移動到另一張表

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