VBA - Copy Row Data Based on Criteria

[unknownymous]

Hello Excel Gurus,

I was thinking of creating a macro based on below criteria:

5 Tabs will be created in running the macro:

1. New - New accounts that doesn't have any previous data (Copy Whole row)
2. Zero - Accounts that doesn't have any score currently but previously existing (Copy Whole row)
3. Positive - Accounts that has positive net change (copy whole row)
4. Negatives - Accounts that has negative Net Change (copy whole row)
5. Static - No changes as compared to previous (copy whole row)

Below is the sample data sheet:

ID	Name	Current	Change	Previous
01	Ben	10000	4000	6000
02	Donna	7500	2000	5500
03	Sean	7000	1500	5500
04	Jane	6000	1000	5000
05	Jem	5000	500	4500
06	Seth	4000	750	3250
07	Andy	1000	0	1000
08	Beth	2000	-5000	7000
09	Bill	4000	-3000	7000
10	Jack	5000	-2000	3000
11	Maine	4000	-1000	5000
12	Len	3000	-500	3500
13	Oscar	0	-1000	1000
14	Step	5000	5000	0

<tbody>
</tbody>

Any help will be much appreciated.

 

[Brombrough]

Hi unknownymous,

Hope the code works for you and enjoy.

Don't forget to rate the reply.

Public Function createNewSsheets()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsR As Worksheet
    Dim wsW As Worksheet
    Dim lngMaxSDSRow As Long
    Dim lngSheetCurRow(5) As Long
    
    Set wb = ThisWorkbook
    
'delete sheets if exists
    GoSub deleteSheets
     
    Set wsR = wb.Worksheets("Sample Data Sheet")                                'change Sheet1 to the name of your Sheet
    
'add new sheets and headings
    GoSub addNewSheets
    
'in excel earlier then 2007 change "A1048576" to "A65536"
    lngMaxSDSRow = wsR.Range("A1048576").End(xlUp).Row                           'find last row of data




'loop through each record and add data to correct worksheet
    For i = 2 To lngMaxSDSRow
        If wsR.Range("E" & i).Value = 0 Then
            'new one
            Set wsW = wb.Worksheets("New")
            wsR.Range("A" & i & ":E" & i).Copy wsW.Range("A" & lngSheetCurRow(1))
            lngSheetCurRow(1) = lngSheetCurRow(1) + 1                             'add 1 to row for next data if found
        ElseIf wsR.Range("C" & i).Value = 0 And wsR.Range("E" & i).Value > 0 Then
            'Zero one
            Set wsW = wb.Worksheets("Zero")
            wsR.Range("A" & i & ":E" & i).Copy wsW.Range("A" & lngSheetCurRow(2))
            lngSheetCurRow(2) = lngSheetCurRow(2) + 1
        ElseIf wsR.Range("D" & i).Value > 0 Then
            'Positive one
            Set wsW = wb.Worksheets("Positive")
            wsR.Range("A" & i & ":E" & i).Copy wsW.Range("A" & lngSheetCurRow(3))
            lngSheetCurRow(3) = lngSheetCurRow(3) + 1
        ElseIf wsR.Range("D" & i).Value < 0 Then
            'Negative one
            Set wsW = wb.Worksheets("Negative")
            wsR.Range("A" & i & ":E" & i).Copy wsW.Range("A" & lngSheetCurRow(4))
            lngSheetCurRow(4) = lngSheetCurRow(4) + 1
        ElseIf wsR.Range("D" & i).Value = 0 Then
            'Static one
            Set wsW = wb.Worksheets("Static")
            wsR.Range("A" & i & ":E" & i).Copy wsW.Range("A" & lngSheetCurRow(5))
            lngSheetCurRow(5) = lngSheetCurRow(5) + 1
        Else
            'no criteria met do nothing
            
        End If
    Next i


'clear references
    Erase lngSheetCurRow
    Set wsW = Nothing
    Set wsR = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Exit Function


deleteSheets:
    For Each ws In wb.Worksheets
        Select Case ws.Name
             Case "New", "Zero", "Positive", "Negative", "Static"
                Application.DisplayAlerts = False
                    ws.Delete
                Application.DisplayAlerts = True
        End Select
    Next
    Return


addNewSheets:
    For i = 1 To 5
        lngSheetCurRow(i) = 2                                               'set new row for data to be pasted
    Next i
'add new sheets and row headers
    wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "New"
        wsR.Range("A1:E1").Copy wb.Worksheets("New").Range("A1")
    wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "Zero"
        wsR.Range("A1:E1").Copy wb.Worksheets("Zero").Range("A1")
    wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "Positive"
        wsR.Range("A1:E1").Copy wb.Worksheets("Positive").Range("A1")
    wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "Negative"
        wsR.Range("A1:E1").Copy wb.Worksheets("Negative").Range("A1")
    wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "Static"
        wsR.Range("A1:E1").Copy wb.Worksheets("Static").Range("A1")
    Return
End Function

 

[unknownymous]

This is amazing! Thank you Brombrough!