Creating New Sheets And Moving Data

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,783
Office Version
  1. 365
Platform
  1. Windows
I have a file with one sheet. What I need the code is to create 8 new sheets and copy the data across meeting the criteria below.

1. The code needs to look at column C and any rows that say cash credit needs putting onto new sheets in the way below.

2. It then needs to look at column F for the depot. If the number is 1, 4, 6 and 10 then a new sheet needs to be PF Cash. If the number is 2, 8, 9 and 12 there needs to be another sheet called LP Cash. If the numbers are 3, 5, 7 and 11 another sheet called SC Cash, and finally number 14 another sheet called DF Cash

3. What should be left on the main data sheet should be rows called Account Credit and Warranty Credit in C and then more sheets added the same way as above. PF Account, LP Account, SC Account and DF Account. But then it also needs to look at column E and only copy across the rows that have numbers 2, 4, 5, 6 and 33

4. The file will then have 9 sheets in total (the 8 created as above plus the data sheet).

<b>Data</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:MS Sans Serif,Arial; font-size:10pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:81px;" /><col style="width:80px;" /><col style="width:133px;" /><col style="width:68px;" /><col style="width:62px;" /><col style="width:51px;" /><col style="width:69px;" /><col style="width:119px;" /><col style="width:70px;" /><col style="width:259px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td><td >F</td><td >G</td><td >H</td><td >I</td><td >J</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">REGNUM</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">CUSTOMER</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">TTYPEST</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">INVDATE</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">REASON</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">DEPOT</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">INVNUM</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">STCODE</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">QUANTITY</td><td style="background-color:#c0c0c0; font-family:Arial; text-align:center; ">DESCRIPN</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td style="font-family:Arial; text-align:left; ">CBD</td><td style="font-family:Arial; text-align:left; ">XRE01</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">07</td><td style="font-family:Arial; text-align:right; ">1</td><td style="font-family:Arial; text-align:left; ">MR123456</td><td style="font-family:Arial; text-align:left; ">ABC123</td><td style="font-family:Arial; text-align:right; ">-2</td><td style="font-family:Arial; text-align:left; ">TEST 1</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td style="font-family:Arial; text-align:left; ">R0634930</td><td style="font-family:Arial; text-align:left; ">XRE06</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">03</td><td style="font-family:Arial; text-align:right; ">6</td><td style="font-family:Arial; text-align:left; ">MR123457</td><td style="font-family:Arial; text-align:left; ">ABC124</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 2</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td style="font-family:Arial; text-align:left; ">R0157821</td><td style="font-family:Arial; text-align:left; ">XRE11</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">1</td><td style="font-family:Arial; text-align:left; ">MR123458</td><td style="font-family:Arial; text-align:left; ">ABC125</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 3</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td style="font-family:Arial; text-align:left; ">CBD</td><td style="font-family:Arial; text-align:left; ">XRE16</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">07</td><td style="font-family:Arial; text-align:right; ">4</td><td style="font-family:Arial; text-align:left; ">MR123459</td><td style="font-family:Arial; text-align:left; ">ABC126</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 4</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td style="font-family:Arial; text-align:left; ">R0345826</td><td style="font-family:Arial; text-align:left; ">XRE21</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">3</td><td style="font-family:Arial; text-align:left; ">MR123460</td><td style="font-family:Arial; text-align:left; ">ABC127</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 5</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td style="font-family:Arial; text-align:left; ">R0345826</td><td style="font-family:Arial; text-align:left; ">XRE26</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">3</td><td style="font-family:Arial; text-align:left; ">MR123461</td><td style="font-family:Arial; text-align:left; ">ABC128</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 6</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td style="font-family:Arial; text-align:left; ">R0157730</td><td style="font-family:Arial; text-align:left; ">XRE31</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">03</td><td style="font-family:Arial; text-align:right; ">1</td><td style="font-family:Arial; text-align:left; ">MR123462</td><td style="font-family:Arial; text-align:left; ">ABC129</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 7</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >9</td><td style="font-family:Arial; text-align:left; ">CBD</td><td style="font-family:Arial; text-align:left; ">XRE36</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">07</td><td style="font-family:Arial; text-align:right; ">6</td><td style="font-family:Arial; text-align:left; ">MR123463</td><td style="font-family:Arial; text-align:left; ">ABC130</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 8</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >10</td><td style="font-family:Arial; text-align:left; ">R1215272</td><td style="font-family:Arial; text-align:left; ">XRE41</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">12</td><td style="font-family:Arial; text-align:left; ">MR123464</td><td style="font-family:Arial; text-align:left; ">ABC131</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 9</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >11</td><td style="font-family:Arial; text-align:left; ">R1215272</td><td style="font-family:Arial; text-align:left; ">XRE46</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">12</td><td style="font-family:Arial; text-align:left; ">MR123465</td><td style="font-family:Arial; text-align:left; ">ABC132</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 10</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >12</td><td style="font-family:Arial; text-align:left; ">R0157820</td><td style="font-family:Arial; text-align:left; ">XRE51</td><td style="font-family:Arial; text-align:left; ">CASH CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">1</td><td style="font-family:Arial; text-align:left; ">MR123466</td><td style="font-family:Arial; text-align:left; ">ABC133</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 11</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >13</td><td style="font-family:Arial; text-align:left; ">R0742616</td><td style="font-family:Arial; text-align:left; ">XRE56</td><td style="font-family:Arial; text-align:left; ">ACCOUNT CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">7</td><td style="font-family:Arial; text-align:left; ">MR123467</td><td style="font-family:Arial; text-align:left; ">ABC134</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 12</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >14</td><td style="font-family:Arial; text-align:left; ">R0742853</td><td style="font-family:Arial; text-align:left; ">XRE61</td><td style="font-family:Arial; text-align:left; ">ACCOUNT CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">7</td><td style="font-family:Arial; text-align:left; ">MR123468</td><td style="font-family:Arial; text-align:left; ">ABC135</td><td style="font-family:Arial; text-align:right; ">-2</td><td style="font-family:Arial; text-align:left; ">TEST 13</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >15</td><td style="font-family:Arial; text-align:left; ">R1418142</td><td style="font-family:Arial; text-align:left; ">XRE66</td><td style="font-family:Arial; text-align:left; ">ACCOUNT CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">14</td><td style="font-family:Arial; text-align:left; ">MR123469</td><td style="font-family:Arial; text-align:left; ">ABC136</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 14</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >16</td><td style="font-family:Arial; text-align:left; ">R0742616</td><td style="font-family:Arial; text-align:left; ">XRE71</td><td style="font-family:Arial; text-align:left; ">WARRANTY CREDIT</td><td style="font-family:Arial; text-align:right; ">21-May-12</td><td style="font-family:Arial; text-align:left; ">01</td><td style="font-family:Arial; text-align:right; ">7</td><td style="font-family:Arial; text-align:left; ">MR123470</td><td style="font-family:Arial; text-align:left; ">ABC137</td><td style="font-family:Arial; text-align:right; ">-1</td><td style="font-family:Arial; text-align:left; ">TEST 15</td></tr></table> <br /><br /><span style="font-family:Arial; font-size:9pt; font-weight:bold;background-color:#ffffff; color:#000000;
 
Sort by date Sort by votes
Hello daz,

Oops, that was my fault. I misspelled the worksheet sheet name. The correction is in red. Since the files have been saved, delete all of the in the desktop folder. Reurn the macro with change and everything should be fine.
Rich (BB code): 
                    If Dir(FolderPath & "\" & Filename) <> "" Then
                        Set Wkb = Workbooks.Open(FolderPath & "\" & Filename)
                            Wkb.Worksheets(1).UsedRange.ClearContents
                            Wkb.Worksheets(2).UsedRange.ClearContents
                    Else
                        Set Wkb = Workbooks.Add()
                            WkbName = Split(WkbName, " ")
                            Wkb.Worksheets(1).Name = WkbName(0) & " Cash " & WkbName(1)
                            Wkb.Worksheets(2).Name = WkbName(0) & " Account " & WkbName(1)
                        Wkb.SaveAs FolderPath & "\" & WkbName(0) & " " & WkbName(1)
                    End If
 
Upvote 0

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
What about the sort problem. I need a sort by column F then by column E both ascending. Thank.
 
Upvote 0
Hello daz,

The time difference is a bother. I have added the sorting to the code below. The macro sorts only the "Data" sheet. All other sheets data will be in the same order when the data is copied over.

The macro will sort with version of Excel. This macro is the one that creates the workbooks. If you need help with adding the sort to the previous version, let me know.
Code: 
' Written: May 29, 2012
' Updated: May 30, 2012 - Added sorting. Works with Excel 95 - 2003, 2007 - 2010
' Author:  Leith Ross (www.mrexcel.com)

Sub SeparateData()

    Dim Cell As Range
    Dim Depot As Long
    Dim Ext As String
    Dim Filename As String
    Dim FolderName As String
    Dim FolderPath As String
    Dim FirstWks As Worksheet
    Dim HeaderRow As Range
    Dim NewSheets(1 To 8) As String
    Dim R As Long
    Dim Reason As Long
    Dim Rng As Range
    Dim Version As Double
    Dim Wkb As Workbook
    Dim WkbName As Variant
    Dim Wks As Worksheet
 
        Application.ScreenUpdating = False
 
        Application.SheetsInNewWorkbook = 2
        
        FolderName = "Test Folder"
        FolderPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & FolderName
        
            Set FirstWks = Worksheets(1)
 
            For Each Wks In Worksheets
                If StrComp(Wks.CodeName, FirstWks.CodeName, vbTextCompare) = -1 Then
                    Set FirstWks = Wks
                End If
            Next Wks
 
            Set Rng = FirstWks.Range("A1").CurrentRegion
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
 
            If Rng Is Nothing Then Exit Sub
        
        
            If Dir(FolderPath, vbDirectory) = "" Then
                MsgBox "The Folder '" & FolderPath & "' could not be found.", vbCritical
                Exit Sub
            End If
        
                Set HeaderRow = FirstWks.Range("A1:J1")
                Version = Val(Application.Version)
                
                #If Version < 12 Then
                    Ext = ".xls"
                    Rng.Sort Key1:=Rng.Columns(6), Order1:=xlAscending, _
                             Key2:=Rng.Columns(5), Order2:=xlAscending, _
                             Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
                #Else
                    Ext = ".xlsx"
                    With FirstWks.Sort
                        .SortFeilds.Clear
                        .SortFields.Add Key:=Columns("F"), _
                            SortOn:=xlSortOnValues, Order:=xlAscending
                        .SortFields.Add Key:=Columns("D"), _
                            SortOn:=xlSortOnValues, Order:=xlAscending
                        .SetRange Rng
                        .Header = xlYes
                        .MatchCase = False
                        .Apply
                    End With
                #End If
            
                For Each WkbName In Array("PF Credits", "LP Credits", "SC Credits", "D14 Credits")
                    Filename = WkbName & Ext
                
                    If Dir(FolderPath & "\" & Filename) <> "" Then
                        Set Wkb = Workbooks.Open(FolderPath & "\" & Filename)
                            Wkb.Worksheets(1).UsedRange.ClearContents
                            Wkb.Worksheets(2).UsedRange.ClearContents
                    Else
                        Set Wkb = Workbooks.Add()
                            WkbName = Split(WkbName, " ")
                            Wkb.Worksheets(1).Name = WkbName(0) & " Cash " & WkbName(1)
                            Wkb.Worksheets(2).Name = WkbName(0) & " Account " & WkbName(1)
                        Wkb.SaveAs FolderPath & "\" & WkbName(0) & " " & WkbName(1)
                    End If
                
                    HeaderRow.Copy Wkb.Worksheets(1).Range("A1")
                    HeaderRow.Copy Wkb.Worksheets(2).Range("A1")

                Next WkbName
        
 
            For Each Cell In Rng.Columns(3).Cells
                Reason = Cell.Offset(0, 2)
                Depot = Cell.Offset(0, 3)
                Set Wks = Nothing
 
                Select Case LCase(Cell)
                    Case Is = "cash credit"
                        Select Case Depot
                            Case 1, 4, 6, 10: Set Wks = Workbooks("PF Credits" & Ext).Worksheets("PF Cash Credits")
                            Case 2, 8, 9, 12: Set Wks = Workbooks("LP Credits" & Ext).Worksheets("LP Cash Credits")
                            Case 3, 5, 7, 11: Set Wks = Workbooks("SC Credits" & Ext).Worksheets("SC Cash Credits")
                            Case 14: Set Wks = Workbooks("D14 Credits" & Ext).Worksheets("D14 Cash Credits")
                        End Select
 
                    Case Is = "account credit", "warranty credit"
                        Select Case Reason
                            Case 2, 4, 5, 6, 33
                                Select Case Depot
                                    Case 1, 4, 6, 10: Set Wks = Workbooks("PF Credits" & Ext).Worksheets("PF Account Credits")
                                    Case 2, 8, 9, 12: Set Wks = Workbooks("LP Credits" & Ext).Worksheets("LP Account Credits")
                                    Case 3, 5, 7, 11: Set Wks = Workbooks("SC Credits" & Ext).Worksheets("SC Account Credits")
                                    Case 14: Set Wks = Workbooks("D14 Credits" & Ext).Worksheets("D14 Account Credits")
                                End Select
                        End Select
                End Select
 
                If Not Wks Is Nothing Then
                    R = Wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cell.EntireRow.Copy Destination:=Wks.Cells(R, "A")
                    Wks.Columns.AutoFit
                    Wks.Rows.AutoFit
                End If
            Next Cell
            
            For Each Wkb In Workbooks
                Wkb.Save
            Next Wkb
            
   Sheets(1).Activate
   Cells.EntireColumn.AutoFit
   Range("A1").Select
   
   Application.ScreenUpdating = True
   Application.SheetsInNewWorkbook = 3
   
End Sub
 
Upvote 0
Thanks Leith, the code below is what I am using for the one that adds the sheets to the workbook. I used my iniative a bit and added the section in red that adds across all the warranty credits over to the account credits sheets. It seems to work! Just need help with the sort, F then E

Rich (BB code): 
Sub SeparateData()
Application.ScreenUpdating = False
    Dim Cell As Range
    Dim Depot As Long
    Dim FirstWks As Worksheet
    Dim HeaderRow As Range
    Dim NewSheets(1 To 8) As String
    Dim Reason As Long
    Dim Rng As Range
    Dim Wks As Worksheet
    
        Set FirstWks = Worksheets(1)
        
        For Each Wks In Worksheets
            If StrComp(Wks.CodeName, FirstWks.CodeName, vbTextCompare) = -1 Then
                Set FirstWks = Wks
            End If
        Next Wks
        
        Set Rng = FirstWks.Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))
        
        If Rng Is Nothing Then Exit Sub
        
       ' FirstWks.Columns.AutoFit
        'Rng.Cells.Sort Key1:=Sheet1.Cells(2, 5), Order1:=xlAscending, Header:=xlYes
        Set HeaderRow = FirstWks.Range("A1:J1")
        
        For Each NewSheet In Array("PF Cash Credits", "PF Account Credits", "SC Cash Credits", "SC Account Credits", "LP Cash Credits", "LP Account Credits", "D14 Cash Credits", "D14 Account Credits")
            On Error Resume Next
                Set Wks = Worksheets(NewSheet)
                If Err = 9 Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = NewSheet
                    HeaderRow.Copy Destination:=Range("A1")
                    Range("A2").Select
                End If
            On Error GoTo 0
        Next NewSheet
            
            For Each Cell In Rng.Columns(3).Cells
                Reason = Cell.Offset(0, 2)
                Depot = Cell.Offset(0, 3)
                Set Wks = Nothing
                
                Select Case LCase(Cell)
                    Case Is = "cash credit"
                        Select Case Depot
                            Case 1, 4, 6, 10: Set Wks = Worksheets("PF Cash Credits")
                            Case 2, 8, 9, 12: Set Wks = Worksheets("LP Cash Credits")
                            Case 3, 5, 7, 11: Set Wks = Worksheets("SC Cash Credits")
                            Case 14: Set Wks = Worksheets("D14 Cash Credits")
                        End Select
                        
                        'Case Is = "warranty credit"
                                'Select Case Depot
                                   ' Case 1, 4, 6, 10: Set Wks = Worksheets("PF Account Credits")
                                   ' Case 2, 8, 9, 12: Set Wks = Worksheets("LP Account Credits")
                                   ' Case 3, 5, 7, 11: Set Wks = Worksheets("SC Account Credits")
                                   ' Case 14: Set Wks = Worksheets("D14 Account Credits")
                        'End Select
                    Case Is = "account credit"
                        Select Case Reason
                            Case 2, 4, 5, 6, 33
                                Select Case Depot
                                    Case 1, 4, 6, 10: Set Wks = Worksheets("PF Account Credits")
                                    Case 2, 8, 9, 12: Set Wks = Worksheets("LP Account Credits")
                                    Case 3, 5, 7, 11: Set Wks = Worksheets("SC Account Credits")
                                    Case 14: Set Wks = Worksheets("D14 Account Credits")
                                End Select
                        End Select
                End Select
                
                If Not Wks Is Nothing Then
                    R = Wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cell.EntireRow.Copy Destination:=Wks.Cells(R, "A")
                    Wks.Columns.AutoFit
                    Wks.Rows.AutoFit
                    Rng.Cells.Sort Key1:=Sheet1.Cells(1, 5), Order1:=xlAscending, Header:=xlYes
                End If
            Next Cell
            ActiveWindow.TabRatio = 0.936
    ActiveWindow.ScrollWorkbookTabs Sheets:=-7
    Sheets(1).Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hello daz,

Here is the macro with the sorting added. Good job on your initiative! The Case statement can take more than one argument. When there is more than one, it it treated like an OR condition. You will see your added Case statement is the same as the "cash". The only difference is the cell value is "warranty".

I noticed in this code you did not add the folder path. It is added just in case.
Code: 
Sub SeparateData()

    Dim Cell As Range
    Dim Depot As Long
    Dim Filename As String
    Dim FirstWks As Worksheet
    Dim FolderPath As String
    Dim HeaderRow As Range
    Dim NewSheet As Variant
    Dim R As Long
    Dim Reason As Long
    Dim Rng As Range
    Dim Version As Double
    Dim Wks As Worksheet
    
        Application.ScreenUpdating = False
        
        FolderPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "New Folder (2)"

        Set FirstWks = Worksheets(1)
        
        For Each Wks In Worksheets
            If StrComp(Wks.CodeName, FirstWks.CodeName, vbTextCompare) = -1 Then
                Set FirstWks = Wks
            End If
        Next Wks
        
        Set Rng = FirstWks.Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))
        
        If Rng Is Nothing Then Exit Sub
        
        Set HeaderRow = FirstWks.Range("A1:J1")
        Version = Val(Application.Version)
                
                #If Version < 12 Then
                    Ext = ".xls"
                    Rng.Sort Key1:=Rng.Columns(6), Order1:=xlAscending, _
                             Key2:=Rng.Columns(5), Order2:=xlAscending, _
                             Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
                #Else
                    Ext = ".xlsx"
                    With FirstWks.Sort
                        .SortFeilds.Clear
                        .SortFields.Add Key:=Columns("F"), _
                            SortOn:=xlSortOnValues, Order:=xlAscending
                        .SortFields.Add Key:=Columns("D"), _
                            SortOn:=xlSortOnValues, Order:=xlAscending
                        .SetRange Rng
                        .Header = xlYes
                        .MatchCase = False
                        .Apply
                    End With
                #End If
        
        
        For Each NewSheet In Array("PF Cash Credits", "PF Account Credits", "SC Cash Credits", "SC Account Credits", "LP Cash Credits", "LP Account Credits", "D14 Cash Credits", "D14 Account Credits")
            On Error Resume Next
                Set Wks = Worksheets(NewSheet)
                If Err = 9 Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = NewSheet
                    HeaderRow.Copy Destination:=Range("A1")
                    Range("A2").Select
                End If
            On Error GoTo 0
        Next NewSheet
            
            For Each Cell In Rng.Columns(3).Cells
                Reason = Cell.Offset(0, 2)
                Depot = Cell.Offset(0, 3)
                Set Wks = Nothing
                
                Select Case LCase(Cell)
                    Case Is = "cash credit", "warranty credit"
                        Select Case Depot
                            Case 1, 4, 6, 10: Set Wks = Worksheets("PF Cash Credits")
                            Case 2, 8, 9, 12: Set Wks = Worksheets("LP Cash Credits")
                            Case 3, 5, 7, 11: Set Wks = Worksheets("SC Cash Credits")
                            Case 14: Set Wks = Worksheets("D14 Cash Credits")
                        End Select
                        
                        'Case Is = "warranty credit"
                                'Select Case Depot
                                   ' Case 1, 4, 6, 10: Set Wks = Worksheets("PF Account Credits")
                                   ' Case 2, 8, 9, 12: Set Wks = Worksheets("LP Account Credits")
                                   ' Case 3, 5, 7, 11: Set Wks = Worksheets("SC Account Credits")
                                   ' Case 14: Set Wks = Worksheets("D14 Account Credits")
                        'End Select
                    Case Is = "account credit"
                        Select Case Reason
                            Case 2, 4, 5, 6, 33
                                Select Case Depot
                                    Case 1, 4, 6, 10: Set Wks = Worksheets("PF Account Credits")
                                    Case 2, 8, 9, 12: Set Wks = Worksheets("LP Account Credits")
                                    Case 3, 5, 7, 11: Set Wks = Worksheets("SC Account Credits")
                                    Case 14: Set Wks = Worksheets("D14 Account Credits")
                                End Select
                        End Select
                End Select
                
                If Not Wks Is Nothing Then
                    R = Wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cell.EntireRow.Copy Destination:=Wks.Cells(R, "A")
                    Wks.Columns.AutoFit
                    Wks.Rows.AutoFit
                    Rng.Cells.Sort Key1:=Sheet1.Cells(1, 5), Order1:=xlAscending, Header:=xlYes
                End If
            Next Cell
            
    ActiveWindow.TabRatio = 0.936
    ActiveWindow.ScrollWorkbookTabs Sheets:=-7
    Sheets(1).Select
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
The folder path is not needed on this one because this is the code that adds the sheets to the existing data file.

The code I posted works ok apart from the sort I need
 
Upvote 0
The code runs and sorts and completes ok when the code is put in the workbook module, but when I put the code in the personal macro workbook which is what I need I get an error on this line

Rng.Cells.Sort Key1:=Sheet1.Cells(1, 5), Order1:=xlAscending, Header:=xlYes

Also could you take that folder part out please as it may confuse things.
 
Upvote 0
Hello daz,

Definitely not enough coffee. Go ahead and delete that line. The sorting is done at the top of the macro now.
 
Upvote 0
I think we are nearly there. If you still have that data file I sent you could you look at row 2. That never gets included in the sort and stays at the top when its put in its respective sheet (PF Cash Credits).

Also could the folder path be removed just to stop confusion. Thanks a lot
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
571
smozgur
smozgur
E
  • Question Question
VBA code clean up
Replies
9
Views
536
mumps
mumps
E
  • Question Question
Adding a custom message.
Replies
1
Views
645
Micron
M
D
  • Question Question
Looking for a way to allocate shifts between teams, maybe a LET formula
Replies
0
Views
86
Dazzybeeguy
D
A
  • Locked
  • Question Question
values across tables found by name
Replies
2
Views
483
Fluff
Fluff

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top