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
    Senior Member DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    378
    Rep Power
    4

    Multiple Worksheet Splitting. Maintain Formats

    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 _ ? ??? _ – You make this manually. This should show us what you want. This should be a typical output as you want it. Show us what you want. Make a File to look like what you want the code to make it like is to be.


    Maybe this can help a little:
    Code:
    Sub testie() '  http://www.excelfox.com/forum/showthread.php/2226-Multiple-sheet-splitting?p=10457#post10457
     Dim ws As Worksheet, e, i As Long, ii As Long, w, wb As Workbook
     Dim hAry() As Variant, WTFisThis() As Variant ' Main Data Array, some sort of reordered output Array
        With CreateObject("Scripting.Dictionary")
         .CompareMode = 1
            For Each ws In Worksheets
             Let hAry() = Intersect(ws.Rows("3:" & Rows.Count), ws.Range("a3").CurrentRegion).Value
             ReDim WTFisThis(1 To UBound(hAry, 2)) ' 1 to all columns in main Array
                For i = 2 To UBound(hAry, 1)
                    If Not .exists(hAry(i, 1)) Then
                     Set .Item(hAry(i, 1)) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not .Item(hAry(i, 1)).exists(ws.Name) Then
                     Set .Item(hAry(i, 1))(ws.Name) = CreateObject("System.Collections.ArrayList")
                        For ii = 1 To UBound(hAry(), 2)
                         WTFisThis(ii) = hAry(1, ii)
                        Next
                     .Item(hAry(i, 1))(ws.Name).Add WTFisThis()
                    End If
                    For ii = 1 To UBound(hAry, 2)
                     WTFisThis(ii) = hAry(i, ii)
                    Next
                 .Item(hAry(i, 1))(ws.Name).Add WTFisThis()
                Next i
            Next ws
            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
                  WTFisThis() = Application.Index(.Item(e).items()(i).ToArray, 0, 0)
                  wb.Sheets(.Item(e).keys()(i)).Cells(1).Resize(UBound(WTFisThis(), 1), UBound(WTFisThis(), 2)).Value = WTFisThis()
                 Workbooks("SPLIT1.xlsm").Worksheets.Item(1).Range("A3").Copy '                                                    '    https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-copy-method-excel
                 wb.Sheets(.Item(e).keys()(i)).Cells(1).Resize(1, UBound(WTFisThis(), 2)).PasteSpecial Paste:=xlPasteFormats       '    https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-pastespecial-method-excel    https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlpastetype-enumeration-excel
                                                                                                                                                            'wb.Sheets(.Item(e).keys()(i)).Cells(1).Resize(1, UBound(WTFisThis(), 2)).PasteSpecial Paste:=xlPasteColumnWidths       '    https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-pastespecial-method-excel    https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlpastetype-enumeration-excel
                Next i
             wb.SaveAs ThisWorkbook.Path & "\" & e & ".xlsx"
             wb.Close
            Next e
        End With
    End Sub


    This code will also copy format of column row. I think this may be something similar to what you want.
    sachin482ColumnFormat.JPG : https://imgur.com/SzLPHmO
    sachin482ColumnFormat.jpg


    I think to get further help you must try to explain much more fully and in much more detail what it is that you want.
    I do not really understand what you want.
    I do not fully understand what your code is doing.

    Alan
    Google first, like this site:ExcelFox.com "Short Title or Theme of wot you’re looking for"
    Use Code Tags: Highlight code; click on the # icon above,
    Post screenshots COPYABLE to a Spredsheet; NOT IMAGES PLEASE:
    Tools for that:
    http://www.excelfox.com/forum/showth...=9821#post9821
    https://app.box.com/s/gjpa8mk8ko4vkwcke3ig2w8z2wkfvrtv
    http://excelmatters.com/excel-forums/

  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
    Senior Member DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    378
    Rep Power
    4
    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 01:19 PM. Reason: cross post seen
    Google first, like this site:ExcelFox.com "Short Title or Theme of wot you’re looking for"
    Use Code Tags: Highlight code; click on the # icon above,
    Post screenshots COPYABLE to a Spredsheet; NOT IMAGES PLEASE:
    Tools for that:
    http://www.excelfox.com/forum/showth...=9821#post9821
    https://app.box.com/s/gjpa8mk8ko4vkwcke3ig2w8z2wkfvrtv
    http://excelmatters.com/excel-forums/

Similar Threads

  1. Replies: 2
    Last Post: 07-20-2017, 08:02 AM
  2. Replies: 1
    Last Post: 06-11-2015, 09:33 AM
  3. Splitting userform text onto different rows
    By achar in forum Excel Help
    Replies: 1
    Last Post: 02-21-2015, 07:34 PM
  4. Splitting and merging files with VBA
    By tryingtocode in forum Excel Help
    Replies: 1
    Last Post: 05-23-2013, 11:07 PM
  5. Combine Columns From Multiple Sheets To One Sheet
    By Portucale in forum Excel Help
    Replies: 6
    Last Post: 04-24-2013, 09:48 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
  •