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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Current[/TD]
[TD]Change[/TD]
[TD]Previous[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Ben[/TD]
[TD]10000[/TD]
[TD]4000[/TD]
[TD]6000[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Donna[/TD]
[TD]7500[/TD]
[TD]2000[/TD]
[TD]5500[/TD]
[/TR]
[TR]
[TD]03[/TD]
[TD]Sean[/TD]
[TD]7000[/TD]
[TD]1500[/TD]
[TD]5500[/TD]
[/TR]
[TR]
[TD]04[/TD]
[TD]Jane[/TD]
[TD]6000[/TD]
[TD]1000[/TD]
[TD]5000[/TD]
[/TR]
[TR]
[TD]05[/TD]
[TD]Jem[/TD]
[TD]5000[/TD]
[TD]500[/TD]
[TD]4500[/TD]
[/TR]
[TR]
[TD]06[/TD]
[TD]Seth[/TD]
[TD]4000[/TD]
[TD]750[/TD]
[TD]3250[/TD]
[/TR]
[TR]
[TD]07[/TD]
[TD]Andy[/TD]
[TD]1000[/TD]
[TD]0[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]08[/TD]
[TD]Beth[/TD]
[TD]2000[/TD]
[TD]-5000[/TD]
[TD]7000[/TD]
[/TR]
[TR]
[TD]09[/TD]
[TD]Bill[/TD]
[TD]4000[/TD]
[TD]-3000[/TD]
[TD]7000[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]Jack[/TD]
[TD]5000[/TD]
[TD]-2000[/TD]
[TD]3000[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]Maine[/TD]
[TD]4000[/TD]
[TD]-1000[/TD]
[TD]5000[/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]Len[/TD]
[TD]3000[/TD]
[TD]-500[/TD]
[TD]3500[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]Oscar[/TD]
[TD]0[/TD]
[TD]-1000[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]Step[/TD]
[TD]5000[/TD]
[TD]5000[/TD]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]


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!