Excel Forum

Code: Select all

Sub SeparateData()
Dim a() As Variant, rAllrange As Range
Dim rAll As Range, rp As Range, rf As Range
Dim r As Range, count As Long
Dim lng As Long, i As Integer
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Worksheets("Sheet1")
    Set rAll = .Range("A3", .Range("A" & Rows.count).End(xlUp))
    Set rp = .Range("A3")
    Set rAllrange = .Range("A2", .Range("F" & Rows.count).End(xlUp))
    Set rf = .Range("H2")
End With
For Each r In rAll
    count = count + 1
    Set rp = rp.Resize(count, 1)
    If Application.CountIf(rp, r) = 1 Then
        ReDim Preserve a(lng)
        a(lng) = r
        lng = lng + 1
    End If
Next r
For i = LBound(a) To UBound(a)
    rf = a(i)
    rAllrange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("H1:H2")
    rAllrange.SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add After:=Sheets(Sheets.count)
    Sheets(Sheets.count).Name = a(i)
    If Err <> 0 Then
        MsgBox "Check your sheet's name"
        ActiveSheet.Delete
        Sheets("Sheet1").ShowAllData
        Exit Sub
    End If
    ActiveSheet.Range("A1").PasteSpecial xlPasteValues
    Sheets("Sheet1").Activate
   Next i
Sheets("Sheet1").ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"
End Sub

Code: Select all

Sub SeparateData()
Dim a() As Variant, rAllrange As Range
Dim rAll As Range, rp As Range, rf As Range
Dim r As Range, count As Long
Dim lng As Long, i As Integer, j As Integer
Dim wh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ClearAllSheets
SortCashData
With Worksheets("cash")
    Set rAll = .Range("B3", .Range("B" & Rows.count).End(xlUp))
    Set rp = .Range("B3")
    Set rAllrange = .Range("A2", .Range("F" & Rows.count).End(xlUp))
    Set rf = .Range("I3")
End With
For Each r In rAll
    count = count + 1
    Set rp = rp.Resize(count, 1)
    If Application.CountIf(rp, r) = 1 Then
        ReDim Preserve a(lng)
        a(lng) = r
        lng = lng + 1
    End If
Next r
For i = LBound(a) To UBound(a)
    rf = a(i)
    For Each wh In Worksheets
        If wh.Name = a(i) Then
            j = j + 1
        End If
    Next wh
    If j = 0 Then
        Sheets.Add After:=Sheets(Sheets.count)
        Sheets(Sheets.count).Name = a(i)
    End If
    Sheets("cash").Activate
    rAllrange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("I2:I3")
    rAllrange.SpecialCells(xlCellTypeVisible).Copy
    Worksheets(a(i)).Range("A1").PasteSpecial xlPasteValues
    Sheets("cash").Activate
    j = 0
   Next i
Sheets("cash").ShowAllData
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"
End Sub

Sub SortCashData()
Dim r As Range
   Set r = Worksheets("cash").Range("A2").CurrentRegion
   With r
        .Sort Key1:=.Range("B1"), Order1:=xlAscending, Key2:=.Range("C1") _
        , Order2:=xlAscending, Key3:=.Range("A1"), Order3:=xlAscending, Header:= _
        xlGuess
    End With
End Sub

Sub ClearAllSheets()
Dim wh As Worksheet
For Each wh In Worksheets
    If wh.Name <> "cash" Then
        wh.Cells.Clear
    End If
Next wh
End Sub