Macro to move rows to another sheet based on cell value - vba

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