Results 1 to 2 of 2

Thread: Show Details across Multiple sheets

  1. #1
    Seeker The_excell_initiate's Avatar
    Join Date
    Nov 2015
    Posts
    9
    Articles
    0
    Excel Version
    2013, 2016

    Show Details across Multiple sheets



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hey All,

    It seems like either I am missing something basic or MS did.

    I have a pivot table with a list of 25 people something like this :

    james.jameson@corp.com 56
    peter.petersson@corp.com 10
    justbob@corp.com 11
    Weekly I need to create an individual workbook, which is just a "show details" sheet.
    I am currently using KUtools (free trial ) to split the sheets into workbooks, but i still haven't found a way to show details of all in one go. I am stuck double-clicking each name. Ideas?

  2. #2
    Conjurer Logit's Avatar
    Join Date
    Nov 2016
    Posts
    223
    Articles
    0
    Excel Version
    2007
    .
    Here are the macros :

    Code:
    Option Explicit
    
    
    Sub CreateSheets()
    
    
        Dim Cell    As Range
        Dim RngBeg  As Range
        Dim RngEnd  As Range
        Dim Wks     As Worksheet
    
    
            Set RngBeg = Worksheets("Master").Range("A2")
            Set RngEnd = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp)
    
    
            ' Exit if the list is empty.
            If RngEnd.Row < RngBeg.Row Then Exit Sub
    Application.ScreenUpdating = False
            For Each Cell In Worksheets("Master").Range(RngBeg, RngEnd)
                On Error Resume Next
                    ' No error means the worksheet exists.
                    Set Wks = Worksheets(Cell.Value)
    
    
                    ' Add a new worksheet and name it.
                    If Err <> 0 Then
                        Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                        Wks.Name = Cell.Value
                    End If
                On Error GoTo 0
            Next Cell
    Application.ScreenUpdating = True
    MakeHeaders
    End Sub
    
    
    Sub MakeHeaders()
    Dim srcSheet As String
    Dim dst As Integer
    srcSheet = "Master"
    Application.ScreenUpdating = False
    For dst = 1 To Sheets.Count
        If Sheets(dst).Name <> srcSheet Then
        Sheets(srcSheet).Rows("1:1").Copy
        Sheets(dst).Activate
        Sheets(dst).Range("A1").PasteSpecial xlPasteValues
        'ActiveSheet.PasteSpecial xlPasteValues
        Sheets(dst).Range("A1").Select
        End If
    Next
    Application.ScreenUpdating = True
    CopyData
    End Sub
    
    
    Sub CopyData()
    Application.ScreenUpdating = False
    Dim i As Long
    Dim Lastrow As Long
    On Error GoTo M
    Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
    Dim ans As String
        For i = 2 To Lastrow
        ans = Sheets("Master").Cells(i, 1).Value
            Sheets("Master").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Next
    Application.ScreenUpdating = True
    
    
    Sheets("Master").Activate
    Sheets("Master").Range("A1").Select
    
    
    SplitWorkbook
    
    
    Exit Sub
    
    
    M:
    MsgBox "No such sheet as  " & ans & " exist"
    Application.ScreenUpdating = True
    
    
    End Sub
    
    
     
    Sub SplitWorkbook()
    Dim FileExtStr, DateString, xFile As String
    Dim FileFormatNum As Long
    Dim xWs As Worksheet
    Dim xWb As Workbook
    Dim FolderName As String
    Application.ScreenUpdating = False
    Set xWb = Application.ThisWorkbook
    DateString = Format(Now, "yyyy-mm-dd hhmm")
    FolderName = xWb.path & "\" & xWb.Name & " " & DateString
    MkDir FolderName
    For Each xWs In xWb.Worksheets
        xWs.Copy
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            Select Case xWb.FileFormat
                Case 51:
                    FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If Application.ActiveWorkbook.HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56:
                    FileExtStr = ".xls": FileFormatNum = 56
                Case Else:
                    FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
        xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
        Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
        Application.ActiveWorkbook.Close False
    Next
    MsgBox "You can find the files in " & FolderName
    Application.ScreenUpdating = True
    End Sub
    Place the workbook in its own folder. New WB's created from each sheet will be saved in the same folder.
    Attached Files Attached Files

Posting Permissions

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