Show Details across Multiple sheets

The_excell_initiate

New member
Joined
Nov 24, 2015
Messages
9
Reaction score
0
Points
0
Excel Version(s)
2013, 2016
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.com56
peter.petersson@corp.com10
justbob@corp.com11
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?
 
.
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.
 

Attachments

  • Tabs Create From List Copy Data.xlsm
    20.6 KB · Views: 3
Back
Top