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

Question

The below macros works for - I have a workbook with two sheets (Active and Archive). And in Active sheet i have AB column that contains Active or Archive status. If its status Archive macros cuts and moves the row to the sheet Archive. This macros works perfect.

Now i need to add some other sheets to excel and named them (New, Accepted, Rejected) and of course i add the same status to the column AB. Now i want macros to do the same if AB = Archive or New or Accepted or Rejected cut and move the row to the sheet named Archive or New or Accepted or Rejected. I tried it by myself but can't do it.

Need ur help. Thanks in advance.

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

You can set up multiple variables and choose the right ones in a select case. There is some repetition here that could get cleaned up with arrays.

    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

EDIT: Below is the array based version that repeats itself less. Also, I found I kept overwriting my top row in the target sheets, so I added 2 (not 1) to the target counters when I initialized them. If the original was working in your context, you may switch it back.

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