Macro Code for Splitting one sheet data into multiples sheets where same column name must be together in one sheet RRS feed

  • Question

  • Hi,

    I have one concern that I have to split one sheet data into multiples sheets.

    Based on condition as below.

    Main Sheet contain following

    Columns : Akshay, Aman, Akshay, Jon, Jon, Aman, Lili, Lili

    Main Sheet consists of  details of above persons .

    I need to split the Main Sheet into separate sheet for each of individual person.

    Means after splitting 1 sheet contains 2 columns of Akshay together, second sheet should contain 2 columns of Aman and so on

    Would appreciate if any body can provide such macro code.

    Thanks in advance



    Monday, July 31, 2017 9:44 AM

All replies

  • Assumes that your first sheet starts in cell A1, with the headers in row 1, and that each header appears twice, with no other headers.

    Sub TestMacro()
        Dim shD As Worksheet
        Dim shN As Worksheet
        Dim i As Integer
        Set shD = ActiveSheet
        With shD.Sort
            .SortFields.Add Key:=Range("1:1"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange shD.UsedRange
            .Header = xlYes
            .Orientation = xlLeftToRight
        End With
        For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 2
            Set shN = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            shD.Columns(i).Resize(, 2).Copy shN.Range("A:B")
            shN.Name = shN.Cells(1, 1).Value
        Next i
        Application.CutCopyMode = False

    End Sub

    Monday, July 31, 2017 6:05 PM
  • Hello Avis,

    Please test the following code:

    Sub Demo()
    Dim shtName() As String
    Dim foundCell As Range
    Dim shN As Worksheet
    Dim rng As Range
    Application.ScreenUpdating = False
    ReDim Preserve shtName(0)
    shtName(0) = Sheets("Sheet1").Range("A1").Value
    For Each cell In Sheets("Sheet1").Range("A1:H1")
    If UBound(Filter(shtName, cell.Value)) = -1 Then
    i = i + 1
    ReDim Preserve shtName(i)
    shtName(i) = cell.Value
    End If
    For i = 0 To UBound(shtName)
    Set shN = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    shN.Name = shtName(i)
    Set foundCell = Sheets("Sheet1").Cells.Find(shtName(i), LookIn:=xlValues)
      If Not foundCell Is Nothing Then
            firstAddress = foundCell.Address
            Debug.Print foundCell.Address
            If rng Is Nothing Then
                Set rng = Sheets("Sheet1").Columns(foundCell.Column)
                Set rng = Application.Union(rng, Sheets("Sheet1").Columns(foundCell.Column))
            End If
            Set foundCell = Sheets("Sheet1").Cells.FindNext(foundCell)
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
        End If
        Set rng = Nothing
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End Sub



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact

    Tuesday, August 1, 2017 2:47 AM