• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Split Data

A

adeel1

Member
hello guru's

need your expertise one more time...!! hopefully you will help
in attached sheet i want to split data into different sheet (in same sheet) with cell given name..
most of time i split data with column C,D and G, kindly provide general VBA where i just change column number (like C,D or G) and get the required result...

pl note: this is just sample sheet range can be differ..

Adeel
 

Attachments

  • 4710170.xlsx
    47.6 KB · Views: 10
dear Asheesh
thnx for your support

VBA which provided in link not working, when change to vcol =3 sheets created but all blanks and VBA is showing error in when i changed to 4 nad 7..pl help

adeel
 
Hello Adeel
Try this codification so as to get correct results (The strings in Column C exceed 32 characters and this is forbidden for sheet names so I devised Temp array to get new names for sheets)
Code: 
Sub Parse_Data()
    Dim Lr          As Long
    Dim Ws          As Worksheet
    Dim vCol        As Integer
    Dim I          As Long
    Dim iCol        As Long
    Dim myArr      As Variant
    Dim Temp        As Variant
    Dim Title      As String
    Dim titleRow    As Integer

    vCol = 3
    Set Ws = Sheets("Sheet1")
    Lr = Ws.Cells(Ws.Rows.Count, vCol).End(xlUp).Row
    Title = "A1:I1"
    titleRow = Ws.Range(Title).Cells(1).Row
    iCol = Ws.Columns.Count

    SpeedUp
        Ws.Cells(1, iCol) = "Unique"
        For I = 2 To Lr
            On Error Resume Next
            If VBA.Trim(Ws.Cells(I, vCol)) <> "" And Application.WorksheetFunction.Match(VBA.Trim(Ws.Cells(I, vCol)), Ws.Columns(iCol), 0) = 0 Then
                Ws.Cells(Ws.Rows.Count, iCol).End(xlUp).Offset(1) = VBA.Trim(Ws.Cells(I, vCol))
            End If
        Next I
   
        myArr = Application.WorksheetFunction.Transpose(Ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
        ReDim Temp(1 To UBound(myArr))
        For I = 2 To UBound(myArr)
            Temp(I) = "Output" & I - 1
        Next I
   
        Ws.Columns(iCol).Clear
   
        For I = 2 To UBound(myArr)
            Ws.Range(Title).AutoFilter Field:=vCol, Criteria1:=myArr(I) & ""
            If Not Evaluate("=ISREF('" & Temp(I) & "'!A1)") Then
                Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = Temp(I) & ""
            Else
                Sheets(Temp(I) & "").Move after:=Worksheets(Worksheets.Count)
            End If
           
            Ws.Range("A" & titleRow & ":A" & Lr).EntireRow.Copy Sheets(Temp(I) & "").Range("A1")
            Sheets(Temp(I) & "").Columns.AutoFit
            Sheets(Temp(I) & "").DisplayRightToLeft = False
        Next I
   
        Ws.AutoFilterMode = False
        Ws.Activate
    SpeedDown

    MsgBox "Done...", 64
End Sub

Function SpeedUp()
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
End Function

Function SpeedDown()
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Function
 
Dear sir Yasser Khalil

thanks for helping me and really appreciated your help..sir this code is gud enough but this is not working at column 4 & 7 (i changed this vCol = 4 & 7) or pl guide where to chnage and pl i also want sheet name as in cell name neither output 1 ,2,3 and same for column 4 & 7...!
looking forward to you help me more..

Adeel
 
Last edited:
There is still a problem relating naming sheets as the cell contents exceed the allowed number of characters (Just 31 characters I think)
 
You must log in or register to reply here.
Back
Top