1

对于每个员工的销售佣金，我有一个包含 300 多个标签的文件。一些员工在一个由 2-6 名员工组成的团队中。团队名称在每个选项卡上，即使是一个团队，也在单元格 AA3 中。我想让 VBA 代码提取所有 AA3（团队名称）与名为“团队”和 $AA$3 的新文件相同的工作表。

我有一个宏可以将每张工作表提取到一个新文件中，但我无法弄清楚如何正确编写循环来完成我所要求的操作。

我将每张工作表提取到新文件的代码如下：

    Sub Copy_Every_Sheet_To_New_Workbook_2()
    'Working in 97-2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim TEAM As String
    Dim Team2 As String


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2010
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .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
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName & "\" & Destwb.Sheets(1).Range("AK2").Value & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
4

1 回答 1

2

按照 Scott 的建议，这里有一个函数，它将返回工作簿中给定单元格地址的所有唯一值。它利用了 Collection 对象以及您只能向其添加唯一值的事实。例如，您第二次尝试添加“团队 A”时，它将跳过它（在 On Error 语句中）：

Function GetUniqueCellValues(wb As Excel.Workbook, cellAddress As String) As Collection
Dim ws As Excel.Worksheet
Dim coll As Collection

Set coll = New Collection
For Each ws In wb.Worksheets
    On Error Resume Next
    coll.Add ws.Range(cellAddress).Value, ws.Range(cellAddress).Text
    On Error GoTo 0
Next ws
Set GetUniqueCellValues = coll
End Function

我喜欢尝试对函数进行编码，以便它们依赖于当前工作簿中的内容或其他内容，而不是对列表进行硬编码。

如果您想要AA3包含代码的工作簿中所有工作表的单元格中的每个唯一值，您可以这样称呼它，即ThisWorkbook：

Sub test()

Dim collTeamNames As Collection
Dim i As Long

Set collTeamNames = GetUniqueCellValues(ThisWorkbook, "AA3")
For i = 1 To collTeamNames.Count
Debug.Print collTeamNames(i)
    'do your processing here
Next i
End Sub
于 2012-09-25T15:04:02.747 回答