多张工作表按名称导出

Option Explicit

Sub ExportByName()
    Const PROC_TITLE As String = "Export By Name"
    ' Log issues using a dictionary.
    Dim eDict As Object: Set eDict = CreateObject("Scripting.Dictionary")
    Dim Success As Boolean ' different message boxes
    On Error GoTo ClearError ' start an error-handling routine
    
    ' Define constants.
    
    Const NAMES_COLUMN As Long = 2
    Const DST_USER_SUBFOLDER As String = "\Desktop\Folder\"
    
    Dim swsNames(): swsNames = VBA.Array( _
        "1994", "1995", "1996", "1997", "1998", "1999", "2000", "2001", _
        "2002", "2003", "2004", "2005", "2006", "2007", "2008", "2009", _
        "2010", "2011", "2012", "2013", "2014", "2015", "2016", "2017", _
        "2018", "2019", "2020", "2021", "2022")
    
    ' Write the data of each worksheet to an array held by a jagged array.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    Dim sCount As Long: sCount = UBound(swsNames) + 1
    Dim sJag(): ReDim sJag(1 To sCount)
    
    Dim sws As Worksheet, stws As Worksheet, sData, sn As Long, sName As String
    Dim rCount As Long, scCount As Long, IsFirstFound As Boolean
    Dim snCount As Long, srCount As Long, cCount As Long
    
    For sn = 1 To sCount
        sName = swsNames(sn - 1)
        On Error Resume Next ' prevent error if worksheet doesn't exist
            Set sws = swb.Worksheets(sName)
        On Error GoTo ClearError ' continue with the error-handling routine
        If Not sws Is Nothing Then ' worksheet exists
            With sws.Range("A1").CurrentRegion
                rCount = .Rows.Count - 1
                scCount = .Columns.Count
                If rCount = 0 Then
                    eDict(sName) = "No data in worksheet." ' log
                Else
                    sData = .Resize(.Rows.Count - 1).Offset(1).Value
                    snCount = snCount + 1
                    sJag(snCount) = sData
                    srCount = srCount + rCount
                    If scCount > cCount Then
                        cCount = scCount
                        ' The first worksheet with the most columns
                        ' will be used as a template,
                        Set stws = sws
                        If IsFirstFound Then
                            eDict(sName) = "Has " & cCount & " columns." ' log
                        End If
                    End If
                    If Not IsFirstFound Then IsFirstFound = True
                End If
            End With
            Set sws = Nothing
        Else ' worksheet doesn't exist
            eDict(sName) = "Worksheet not found." ' log
        End If
    Next sn
    
    If Not IsFirstFound Then GoTo ProcExit
    
    ' Write the data from the jagged array to a 2D one-based array.
    
    ReDim sData(1 To srCount, 1 To cCount)
    
    Dim nr As Long, sr As Long, sc As Long
    
    For sn = 1 To snCount
        For sr = 1 To UBound(sJag(sn), 1)
            nr = nr + 1
            For sc = 1 To UBound(sJag(sn), 2)
                sData(nr, sc) = sJag(sn)(sr, sc)
            Next sc
        Next sr
    Next sn
    
    Erase sJag ' data is in 'sData'
    
    ' Write the unique names (from the array) and the rows of their appearances
    ' to a dictionary: the names to its 'keys' and the rows to collections
    ' held by the 'its' items.
    
    Dim nDict As Object: Set nDict = CreateObject("Scripting.Dictionary")
    nDict.CompareMode = vbTextCompare
    
    Dim sStr As String
    
    For sr = 1 To srCount
        sStr = CStr(sData(sr, NAMES_COLUMN))
        If Not nDict.Exists(sStr) Then Set nDict(sStr) = New Collection
        nDict(sStr).Add sr
    Next sr
    
    ' Using the array and the information in the dictionary,
    ' write the rows of each name to a 2D one-based array held
    ' by a jagged array.
    
    Dim dnCount As Long: dnCount = nDict.Count
    
    Dim dJag(): ReDim dJag(1 To dnCount)
    Dim dNames() As String: ReDim dNames(1 To dnCount)
    
    Dim dData(), nKey, nItem, drCount As Long, dr As Long, dn As Long
    
    For Each nKey In nDict.Keys
        drCount = nDict(nKey).Count
        ReDim dData(1 To drCount, 1 To cCount)
        For Each nItem In nDict(nKey)
            dr = dr + 1
            sr = nItem
            For sc = 1 To cCount
                dData(dr, sc) = sData(sr, sc)
            Next sc
        Next nItem
        dn = dn + 1
        dJag(dn) = dData
        dNames(dn) = nKey
        dr = 0
    Next nKey
    
    Set nDict = Nothing
    Erase sData
    Erase dData
    
    ' Create the template workbook: clear all data below the 2nd row
    ' and clear contents in the first row which will be used
    ' to copy the formatting.
    
    Application.ScreenUpdating = False
    
    stws.Copy
    
    Dim twb As Workbook: Set twb = Workbooks(Workbooks.Count)
    Dim tws As Worksheet: Set tws = twb.Worksheets(1)
    
    Dim trCount As Long: trCount = tws.Rows.Count - 2
    
    With tws.Range("A1").CurrentRegion
        If trCount > 0 Then
                .Resize(trCount).Offset(2).Clear
        End If
        .Rows(2).ClearContents
    End With
        
    ' For each array in the jagged array, copy the template worksheet
    ' to a new workbook, copy the formatting from the first row,
    ' copy the data from the array and save and close it.
    ' Finally, close the template workbook.
    
    Dim dPath As String: dPath = Environ("USERPROFILE") & DST_USER_SUBFOLDER
    'Dim dPath As String: dPath = "C:\Test\"
    
    Dim dwb As Workbook, dws As Worksheet, dFilePath As String, dName As String
    
    For dn = 1 To dnCount
        drCount = UBound(dJag(dn), 1)
        dName = dNames(dn)
        dFilePath = dPath & dName
        
        tws.Copy ' template to new worksheet
        
        Set dwb = Workbooks(Workbooks.Count)
        Set dws = dwb.Worksheets(1)
        dws.Name = dName
        
        With dws.Range("A2").Resize(drCount, cCount)
            .Rows(1).Copy .Resize(drCount - 1).Offset(1) ' copy formatting
            .Value = dJag(dn) ' copy values
        End With
        
        Application.DisplayAlerts = False ' overwrite without confirmation
            dwb.SaveAs dFilePath
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next dn
            
    twb.Close SaveChanges:=False
            
    Success = True
            
    Application.ScreenUpdating = True
            
    ' Inform.
            
ProcExit: ' start exit routine
    On Error Resume Next ' prevent endless loop if error in continuation
    
        Dim mStr As String
        If Not Success Then mStr = "Something went wrong." & vbLf & vbLf
        mStr = mStr & dn & " worksheet" & IIf(dn = 1, "", "s") & " exported."
        
        If eDict.Count > 0 Then
            mStr = mStr & vbLf & vbLf & "Found the following issues:" & vbLf
            For Each nKey In eDict.Keys
                mStr = mStr & vbLf & nKey & vbTab & eDict(nKey)
            Next nKey
        End If
                
        MsgBox mStr, IIf(Success, vbInformation, vbCritical), PROC_TITLE

    On Error GoTo 0
    Exit Sub
ClearError: ' continue with the error-handling routine.
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit ' redirects toward the exit routine
End Sub

问题描述并不包含一个确定实现的所有元素。它看起来更像是一个陷阱练习...所以问题的一个答案是：你创建一个xlsm文件，在其中复制模块中的以下代码。在本书中，你在首先修复目标文件路径后运行SUB helper（）。代码执行以下操作：a）打开目标文件B）从单元格A2中读取叶数据，假设有标题。当列为53时，计算行数。所有工作表的数据写入书的当前工作表。c）我们关闭目标书d）我们按第一列的ID代码而不是按名称对数据进行排序，因为我认为代码是唯一的，而名称可能不是e）我们遍历整个列A，在每一个代码更改的情况下，我们创建一个新的工作表，并复制当前代码/人的块。工作表重命名为“ID_”和id g）在最后，如果我们愿意，我们删除包含所有数据的工作表。
简单地说，我们把这段代码放到一个新的xlsm文件中，它读取另一个excel工作簿的所有工作表，并创建与它读取的数据中不同的人代码一样多的工作表。

Option Explicit

Public Sub doTheJob(fname As String)
   Dim ws As Worksheet, cursht As Worksheet, rwb As Workbook, rws As Worksheet, r As Range, cp As Range
   Dim rwcnt As Long, rc As Long, ri As Long
   Dim TOP_LEFT_CELL As String
   
   Application.ScreenUpdating = False
   Const COLUMNS_CNT = 53
   Const HAVE_HEADER_ROW = 1  'SET IT TO ZERO (0) IF DON'T HAVE HEADER ROW
   TOP_LEFT_CELL = "A" & (HAVE_HEADER_ROW + 1)
   
   Set cursht = ThisWorkbook.ActiveSheet
   cursht.Cells.ClearContents
   Set rwb = Workbooks.Open(fname)
   ri = 1
   For Each rws In rwb.Worksheets
      rwcnt = rws.Cells(Rows.Count, 1).End(xlUp).Row - HAVE_HEADER_ROW
      If (rwcnt > 0) Then
         Set r = rws.Range(TOP_LEFT_CELL)
         Set r = r.Resize(rwcnt, COLUMNS_CNT)
         Set cp = cursht.Cells(ri, 1)
         Call r.Copy(cp)
         ri = ri + rwcnt
      End If
   Next
   Call rwb.Close(False)
   cursht.Activate
   Call sortData(cursht, ri - 1, COLUMNS_CNT)
   Call make_sheets(cursht, ri - 1, COLUMNS_CNT)
   Call cursht.Delete
End Sub

Private Sub sortData(ws As Worksheet, rws As Long, cls As Long)
   Dim srowcnt As String, sr As Range
   
   ws.Sort.SortFields.Clear
   Set sr = ws.Range("A1") 'sort by ID.    Set it "A2" to sort by name

   Call ws.Sort.SortFields.Add2(sr.Resize(rws), xlSortOnValues, xlAscending, xlSortNormal)
   With ws.Sort
      .SetRange sr.Resize(rws, cls)
      .Orientation = xlTopToBottom
      .MatchCase = False
      .Header = xlNo
      .SortMethod = xlPinYin
      .Apply
   End With
End Sub

Private Sub make_sheets(ws As Worksheet, rws As Long, cls As Long)
   Dim cc As Long, rwfrom As Long, wsnew As Worksheet, lws As Worksheet, fr As Range, tr As Range, nm As String
   Dim isDiff As Boolean
   If rws < 2 Then Exit Sub
   Application.ScreenUpdating = False
   rwfrom = 1
   For cc = 2 To rws + 1
      isDiff = ws.Cells(cc - 1, 1) <> ws.Cells(cc, 1)
      If isDiff Then
         Set fr = ws.Range("A" & rwfrom)
         Set fr = fr.Resize(cc - rwfrom, cls)
         Set lws = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
         Set wsnew = ThisWorkbook.Sheets.Add(, lws)
         Set tr = wsnew.Range("A1")
         wsnew.Name = "ID_" & fr.Cells(1, 1).Value
         Call fr.Copy(tr)
         rwfrom = cc
      End If
   Next
   Call ThisWorkbook.Save
End Sub

Sub helper()
   On Error GoTo Lerr
   Application.Cursor = xlWait
   Call doTheJob("C:\Users\aname\Documents\SHEET-YEAR.xlsx")
Lerr:
   On Error GoTo 0
   Application.Cursor = xlDefault
End Sub