使用宏创建标签失败

Question

我需要一些帮助。

我必须操作一个巨大的 excel 文件，但我在使用 VBA 时遇到了一些问题。

这个 excel 文件有 28 个选项卡，全部有 53 列。这些选项卡是关于年份的，有些年份有更多的人。所有第一列都是关于 Person_system_ID，第二列是他的名字，都是大写的。

我尝试使用

chat GPT

编写 VBA 代码来映射所有选项卡并为每个唯一名称创建一个单独的选项卡并保存，但我遇到了一些错误。

这里是聊天GPT写的代码：

Function IsInArray(arr, val) As Boolean
    Dim found As Boolean
    found = False
    
    If IsArray(arr) And Not IsEmpty(arr) Then
        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            If arr(i) = val Then
                found = True
                Exit For
            End If
        Next i
    End If
    
    IsInArray = found
End Function

Sub Create_Individual_Sheets()
    Dim SheetName As String
    Dim NameList() As String
    Dim LastRow As Long
    Dim Year As Integer
    Dim Sheet As Worksheet
    Dim NewSheet As Worksheet
    Dim Name As Variant
    Dim i As Long
    Dim Folder As String
    
    Folder = "C:\Users\Jorjao\Desktop\Folder"
    
    For Year = 1994 To 2022
        Set Sheet = Worksheets(CStr(Year))
        LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
        
        'loop through the name column in the current sheet and add to the name list
        For i = 2 To LastRow
            Name = UCase(Sheet.Cells(i, 2).Value)
            If Not IsInArray(NameList, Name) Then
                ReDim Preserve NameList(UBound(NameList) + 1)
                NameList(UBound(NameList)) = Name
            End If
        Next i
    Next Year
    
    'loop through the name list and create an individual sheet for each name
    For Each Name In NameList
        Set NewSheet = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
        SheetName = Replace(Name, " ", "_")
        NewSheet.Name = SheetName
        
        'loop through each sheet and copy the rows with the current name to the individual sheet
        For Year = 1994 To 2022
            Set Sheet = Worksheets(CStr(Year))
            LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
            
            'loop through the name column in the current sheet and check if the current name is present
            For i = 2 To LastRow
                If UCase(Sheet.Cells(i, 2).Value) = Name Then
                    Sheet.Rows(i).Copy Destination:=NewSheet.Rows(NewSheet.Cells(Rows.Count, 1).End(xlUp).Row.Offset(1))
                End If
            Next i
        Next Year
        
        'save the new sheet in a folder
        NewSheet.Copy
        ActiveWorkbook.SaveAs Filename:=Folder & SheetName & ".xlsx"
        ActiveWorkbook.Close savechanges:=False
    Next Name
End Sub

使用这段代码，我得到：

运行时错误

9

下标超出范围

我也尝试改变一些东西，但我也遇到了一些运行时错误，例如 13 和 424。

Answer 1

从多个工作表按名称导出

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

Answer 2

问题描述不包含确定实施的所有要素。它看起来更像是一个陷阱练习......所以问题的一个答案是： 您创建一个 xlsm 文件，在其中复制模块中的以下代码。在本书中，您首先确定目标文件路径后运行 SUB helper()。该代码执行以下操作： a) 打开目标文件 b) 假设有标题，从单元格 A2 读取叶数据。计算行数，列数为53，将所有sheet的数据写入book的当前sheet。 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