将报告拆分为新的工作簿

Question

我有一份按员工列出财务数据的报告。我想使用一个宏，这样我就可以按名称拆分报告，然后为每个员工创建一个单独的工作簿。

我有下面的 VBA 代码，它们工作正常，但它只能通过为现有报告中的每个人创建一个新选项卡，在同一报告中按员工拆分。我希望此操作相同，但它为每个员工创建一个新工作簿，而不是为现有报告上的每个员工创建一个新选项卡。

我需要修改什么才能实现这个目标？

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim iCol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(iCol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
ws.Columns(iCol).Clear

For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    'Sheets(myarr(i) & "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub

Answer 1

使用Workbooks.Add

Option Explicit

Sub parse_data()

    'This macro splits data into multiple worksheets
    'based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like
    'to filter by, and it just creates these worksheets.
    
    Const TITLE_ROW = 1

    Dim wbOut As Workbook
    Dim ws As Worksheet, wsOut As Worksheet
    Dim iLastRow As Long, iRow As Long
    Dim iFilterCol As Integer
    Dim sPath As String
    
    ' get filter column nu,ber
    iFilterCol = Application.InputBox( _
            prompt:="Which column would you like to filter by?", _
            title:="Filter column", Default:="3", Type:=1)

    If iFilterCol < 1 Then
        MsgBox iFilterCol & " not valid", vbCritical
        Exit Sub
    End If
    
    Set ws = ActiveSheet
    sPath = ThisWorkbook.Path & "\"
    iLastRow = ws.Cells(ws.Rows.Count, iFilterCol).End(xlUp).Row
    
    Dim dict As Object, key
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' get unique values using dictionary
    For iRow = TITLE_ROW + 1 To iLastRow
        key = Trim(ws.Cells(iRow, iFilterCol))
        If Not dict.exists(key) Then
            dict.Add key, iRow
        End If
    Next
     
    ' create separate workbooks
    Application.ScreenUpdating = False
    For Each key In dict
    
        ' apply filter
        ws.Rows(TITLE_ROW).AutoFilter Field:=iFilterCol, Criteria1:=key
        
        ' create new workbook
        Set wbOut = Workbooks.Add
        Set wsOut = wbOut.Sheets(1)
        wsOut.Name = key
        ws.Range("A" & TITLE_ROW & ":A" & iLastRow).EntireRow.Copy wsOut.Range("A1")
        wsOut.Columns.AutoFit
        ' save and close
        wbOut.SaveAs (sPath & key & ".xlsx")
        wbOut.Close False
    
    Next
   
    ws.Activate
    ws.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    MsgBox dict.Count & " workbooks created", vbInformation
End Sub

将报告拆分为新的工作簿

Splitting a report into new workbooks

excel

vba

report