VBA - Copy Row Data Based on Criteria

unknownymous

Board Regular
Joined
Sep 19, 2017
Messages
160
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:

IDNameCurrentChangePrevious
01Ben1000040006000
02Donna750020005500
03Sean700015005500
04Jane600010005000
05Jem50005004500
06Seth40007503250
07Andy100001000
08Beth2000-50007000
09Bill4000-30007000
10Jack5000-20003000
11Maine4000-10005000
12Len3000-5003500
13Oscar0-10001000
14Step500050000

<tbody>
</tbody>


Any help will be much appreciated. :)
 

Brombrough

New Member
Joined
Apr 10, 2017
Messages
49
Hi unknownymous,

Hope the code works for you and enjoy.

Don't forget to rate the reply.



Code:
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
 

Forum statistics

Threads
1,082,273
Messages
5,364,163
Members
400,784
Latest member
reddsables

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top