1

各従業員の販売コミッション用に 300 以上のタブを含むファイルがあります。一部の従業員は、2 ～ 6 人の従業員のチームに所属しています。チーム名は各タブにあり、1 人のチームであってもセル AA3 にあります。AA3 (チーム名) が「チーム」と $AA$3 という名前の新しいファイルに同じであるすべてのシートを抽出する VBA コードが必要です。

各シートを新しいファイルに抽出するマクロがありますが、ループを正しく記述して求めていることを実行する方法がわかりません。

各シートを新しいファイルに抽出するコードは次のとおりです。

    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」を 2 回追加しようとすると、スキップされます (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 に答える