I need to know how to split a excel file in to sheets [Closed]

Report
Posts
2
Registration date
Friday May 16, 2014
Status
Member
Last seen
May 16, 2014
-
Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
-
Hi,

I would like to know how to split the excel fille in to diffrent sheets based on a criteria.

My criteria is , I have Headings A to Z. and my split criteria is based on the heading C.

C may contatin number 1 to 10 and the each sheet should be named with the numbers(name).

Please help me.

1 reply

Posts
2675
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 5, 2020
448
Hi Xcellenthu,

Assuming you have used 1 row as header and that your data sheet is called "Master" (Otherwise alter the code reference; code line 7 and code line 4, respectively). I also assumed that if column C has data then column A contains data as well.

Sub RunMe()
Dim lRow As Long

Sheets("Master").Select
lRow = Range("C1").End(xlDown).Row

For Each cell In Range("C2:C" & lRow)
    If cell.Value = 1 Then
        cell.EntireRow.Copy
        If Not SheetExists("1") Then Sheets.Add.Name = "1"
        Sheets("1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 2 Then
        cell.EntireRow.Copy
        If Not SheetExists("2") Then Sheets.Add.Name = "2"
        Sheets("2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If
    
    If cell.Value = 3 Then
        cell.EntireRow.Copy
        If Not SheetExists("3") Then Sheets.Add.Name = "3"
        Sheets("3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 4 Then
        cell.EntireRow.Copy
        If Not SheetExists("4") Then Sheets.Add.Name = "4"
        Sheets("4").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 5 Then
        cell.EntireRow.Copy
        If Not SheetExists("5") Then Sheets.Add.Name = "5"
        Sheets("5").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 6 Then
        cell.EntireRow.Copy
        If Not SheetExists("6") Then Sheets.Add.Name = "6"
        Sheets("6").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 7 Then
        cell.EntireRow.Copy
        If Not SheetExists("7") Then Sheets.Add.Name = "7"
        Sheets("7").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 8 Then
        cell.EntireRow.Copy
        If Not SheetExists("8") Then Sheets.Add.Name = "8"
        Sheets("8").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 9 Then
        cell.EntireRow.Copy
        If Not SheetExists("9") Then Sheets.Add.Name = "9"
        Sheets("9").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

    If cell.Value = 10 Then
        cell.EntireRow.Copy
        If Not SheetExists("10") Then Sheets.Add.Name = "10"
        Sheets("10").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If

Next cell
        
Application.CutCopyMode = False
        
End Sub

Function SheetExists(SheetName As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet

If Len(Sheets(SheetName).Name) > 0 Then
    SheetExists = True
    Exit Function
End If

NoSuchSheet:
End Function


Best regards,
Trowa

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!