Consulting

Results 1 to 4 of 4

Thread: Create Multiple Excel Files from One file

  1. #1
    VBAX Regular
    Joined
    Nov 2015
    Posts
    43
    Location

    Create Multiple Excel Files from One file

    I have one excel file and wanted to create multiple files out of this one file.
    Any suggestions. The input file (input.xls) and the output file(craig.xls and Kelly.xls) is attached.
    Attached Files Attached Files

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    25,145
    Location
    Public Sub SplitOut()
    Dim this As Worksheet
    Dim shTemp As Worksheet
    Dim pvtTemp As PivotTable
    Dim numrows As Long
    Dim ws As Worksheet
    Dim emp As String
    Dim i As Long
    
        Application.ScreenUpdating = False
    
        With ThisWorkbook
        
            Set this = ActiveSheet
            Set shTemp = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
            .PivotCaches.Create(SourceType:=xlDatabase, _
                                SourceData:="order!R1C1:R9C5", _
                                Version:=xlPivotTableVersion12).CreatePivotTable _
                                        TableDestination:=shTemp.Name & "!R1C1", _
                                        TableName:="pvtTemp", _
                                        DefaultVersion:=xlPivotTableVersion12
            
            Set pvtTemp = ActiveSheet.PivotTables("pvtTemp")
            With pvtTemp
            
                With .PivotFields("AM Name")
                    .Orientation = xlPageField
                    .Position = 1
                End With
                With .PivotFields("Order " & Chr(10) & "Date")
                    .Orientation = xlRowField
                    .Position = 1
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
                With .PivotFields("Order Status")
                    .Orientation = xlRowField
                    .Position = 2
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
                With .PivotFields("Source")
                    .Orientation = xlRowField
                    .Position = 3
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
                With .PivotFields("Employee Id")
                    .Orientation = xlRowField
                    .Position = 4
                    .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                End With
        
                .DisplayFieldCaptions = False
                .ShowDrillIndicators = False
                .RepeatAllLabels xlRepeatLabels
                .ColumnGrand = False
                .RowGrand = False
                .InGridDropZones = True
                .RowAxisLayout xlTabularRow
       
                .ShowPages PageField:="AM Name"
            End With
            
            For i = .Worksheets.Count To 1 Step -1
            
                Set ws = .Worksheets(i)
                If Not ws Is this And Not ws Is shTemp Then
                
                    With ws
                    
                        .Activate
                        emp = .Name
                        .PivotTables(1).PivotSelect "", xlDataAndLabel, True
                        Selection.Copy
                        Selection.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
                        .Rows("2:4").Delete Shift:=xlUp
                        .Columns("D").Insert
                        .Range("A1:E1").Value = Array("Order Date", "Order Status", "Source", "AM Name", "Employee Id")
                        numrows = Application.CountIf(this.Columns("D"), emp)
                        .Range("D2").Resize(numrows).Value = emp
                        .Columns("A:E").AutoFit
                        .Move
                        
                        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & emp & " " & Application.VLookup(emp, this.Columns("D:E"), 2, False)
                        ActiveWorkbook.Close SaveChanges:=False
                    End With
                End If
            Next i
            
            Application.DisplayAlerts = False
            shTemp.Delete
        End With
    
        Application.ScreenUpdating = True
    End Sub
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    VBAX Regular
    Joined
    Nov 2015
    Posts
    43
    Location
    XLD,

    It cut and paste the data from input file to output file and created files for each employee. However, it did not create "SUMMARY" Tab. Any suggestion.

  4. #4

Posting Permissions

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