Results 1 to 4 of 4

Thread: Multiple sheet splitting

  1. #1
    Junior Member
    Join Date
    Oct 2016
    Posts
    3
    Rep Power
    0

    Multiple sheet splitting

    i have a macro as below of splitting multiple sheets but after splitting the formatting gets changed and freeze column also not reflecting i want to keep formatting ,header,aliment and freezing as the main sheet can it is possible

    The same has been posted in other forum as link below
    https://www.mrexcel.com/forum/excel-...splitting.html


    Code:
    Sub test()
        Dim ws As Worksheet, a, e, i As Long, ii As Long, w, wb As Workbook
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For Each ws In Worksheets
                a = Intersect(ws.Rows("3:" & Rows.Count), _
                ws.Range("a3").CurrentRegion).Value
                ReDim w(1 To UBound(a, 2))
                For i = 2 To UBound(a, 1)
                    If Not .exists(a(i, 1)) Then
                        Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not .Item(a(i, 1)).exists(ws.Name) Then
                        Set .Item(a(i, 1))(ws.Name) = _
                        CreateObject("System.Collections.ArrayList")
                        For ii = 1 To UBound(a, 2)
                            w(ii) = a(1, ii)
                        Next
                        .Item(a(i, 1))(ws.Name).Add w
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii) = a(i, ii)
                    Next
                    .Item(a(i, 1))(ws.Name).Add w
                Next
            Next
            For Each e In .keys
                Set wb = Workbooks.Add
                For i = 0 To .Item(e).Count - 1
                    If i + 1 > wb.Sheets.Count Then
                        wb.Sheets.Add after:=wb.Sheets(wb.Sheets.Count)
                        wb.Sheets(wb.Sheets.Count).Name = .Item(e).keys()(i)
                    Else
                        wb.Sheets(i + 1).Name = .Item(e).keys()(i)
                    End If
                    w = Application.Index(.Item(e).items()(i).ToArray, 0, 0)
                    wb.Sheets(.Item(e).keys()(i)).Cells(1) _
                    .Resize(UBound(w, 1), UBound(w, 2)).Value = w
                Next
                wb.SaveAs ThisWorkbook.Path & "\" & e & ".xlsx"
                wb.Close
            Next
        End With
    End Sub
    Attached Files Attached Files

  2. #2
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Hi sachin482

    It would be helpful if you could explain better what your code actually does and how it works.
    Possibly you could put some ' Comments in to explain what is going on ion your code

    I do not understand fully what it is that you want
    Please try to explain better
    Better is for example to show us what is you want in another file
    It is best to upload another file so that you have a _ Before _ ( already have us given thank you ) and an _ After
    _ Before is __ SPLIT1.xlsm
    _ After is _ ? ??? _
    Attached Images Attached Images
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  3. #3
    Junior Member
    Join Date
    Oct 2016
    Posts
    3
    Rep Power
    0
    thanks a lot for your help i have attached the out put required and the same has been resolved as per below macro

    Code:
    Sub SplitData()
        Dim wbk As Workbook
        Dim wsh As Worksheet
        Dim r As Long
        Dim m As Long
        Dim col As New Collection
        Dim v As Variant
        Dim s As String
        On Error Resume Next
        For Each wsh In ThisWorkbook.Worksheets
            m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
            For r = 4 To m
                col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
            Next r
        Next wsh
        On Error GoTo 0
        Application.Cursor = xlWait
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        For Each v In col
            ThisWorkbook.Worksheets.Copy
            Set wbk = ActiveWorkbook
            For Each wsh In wbk.Worksheets
                m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
                For r = m To 4 Step -1
                    If wsh.Range("A" & r).Value <> v Then
                        wsh.Range("A" & r).EntireRow.Delete
                    End If
                Next r
                    If wsh.Range("A4").Value = "" Then wsh.Delete
                Next wsh
                
                s = ThisWorkbook.Path & "\" & v & ".xlsx"
              wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
            wbk.Close
        Next v
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Application.Cursor = xlDefault
    End Sub
    Attached Files Attached Files

  4. #4
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Hi
    Thanks for sharing your solution


    Edit: please do not forget to add links to ALL cross postings
    http://www.eileenslounge.com/viewtopic.php?f=30&t=29037
    Last edited by DocAElstein; 02-04-2018 at 12:49 PM. Reason: cross post seen
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

Similar Threads

  1. Replies: 2
    Last Post: 02-27-2019, 05:35 PM
  2. Replies: 2
    Last Post: 07-20-2017, 07:32 AM
  3. Splitting userform text onto different rows
    By achar in forum Excel Help
    Replies: 1
    Last Post: 02-21-2015, 07:04 PM
  4. Splitting and merging files with VBA
    By tryingtocode in forum Excel Help
    Replies: 1
    Last Post: 05-23-2013, 10:37 PM
  5. Combine Columns From Multiple Sheets To One Sheet
    By Portucale in forum Excel Help
    Replies: 6
    Last Post: 04-24-2013, 09:18 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •