4

ユーザーが現在選択している各ワークシートの名前と、印刷時に開始するページ番号を一覧表示する目次を作成するマクロを作成しようとしています。このページからコードを取得し、以下のように少し変更しました。

ただし、新しいワークシート (「コンテンツ」) が作成されると、それがアクティブな選択されたシートになり、ActiveWindow.SelectedSheets を使用してユーザーが選択したワークシートのコレクションを参照できなくなります。そのため、新しいシートを作成する前にその情報を保存したいと思います。これどうやってするの？

Worksheetsご覧のとおり、型の変数に代入しようとしましたが、これによりエラー メッセージが生成されます。（私も試しCollectionましたがダメでした。）

Sub CreateTableOfContents()
    ' Determine if there is already a Table of Contents
    ' Assume it is there, and if it is not, it will raise an error
    ' if the Err system variable is > 0, you know the sheet is not there
    Dim WST As Worksheet
    Dim SelSheets As Worksheets

    Set SelSheets = ActiveWindow.SelectedSheets

    On Error Resume Next
    Set WST = Worksheets("Contents")
    If Not Err = 0 Then
        ' The Table of contents doesn't exist. Add it
        Set WST = Worksheets.Add(Before:=Worksheets("blankMagnitude"))
        WST.Name = "Contents"
    End If
    On Error GoTo 0

    ' Set up the table of contents page
    WST.[A2] = "Table of Contents"
    With WST.[A6]
        .CurrentRegion.Clear
        .Value = "Subject"
    End With
    WST.[B6] = "Page(s)"
    WST.Range("A1:B1").ColumnWidth = Array(36, 12)
    TOCRow = 7
    PageCount = 0

    ' Do a print preview on all sheets so Excel calcs page breaks
    ' The user must manually close the PrintPreview window
    Msg = "Excel needs to do a print preview to calculate the number of pages." & vbCrLf & "Please dismiss the print preview by clicking close."
    MsgBox Msg
    SelSheets.PrintPreview

    ' Loop through each sheet, collecting TOC information
    For Each S In SelSheets
        If S.Visible = -1 Then
            S.Select
            ThisName = ActiveSheet.Name
            HPages = ActiveSheet.HPageBreaks.Count + 1
            VPages = ActiveSheet.VPageBreaks.Count + 1
            ThisPages = HPages * VPages

            ' Enter info about this sheet on TOC
            WST.Select
            Range("A" & TOCRow).Value = ThisName
            Range("B" & TOCRow).NumberFormat = "@"
            If ThisPages = 1 Then
                Range("B" & TOCRow).Value = PageCount + 1 & " "
            Else
                Range("B" & TOCRow).Value = PageCount + 1 & " " ' & - " & PageCount + ThisPages
            End If
        PageCount = PageCount + ThisPages
        TOCRow = TOCRow + 1
        End If
    Next S
End Sub
4

3 に答える 3

3

私はちょうどあなたのコードを修正しました。これはあなたがしようとしていることですか？正直なところ、あなたがしなければならなかったのは

に変更Dim SelSheets As WorksheetsするDim SelSheetsと、元のコードが機能します:)

Option Explicit

Sub CreateTableOfContents()
    Dim WST As Worksheet, S As Worksheet
    Dim SelSheets
    Dim msg As String
    Dim TOCRow As Long, PageCount As Long, ThisPages As Long
    Dim HPages As Long, VPages As Long

    Set SelSheets = ActiveWindow.SelectedSheets

    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Contents").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set WST = Worksheets.Add(Before:=Worksheets("blankMagnitude"))

    With WST
        .Name = "Contents"
        .[A2] = "Table of Contents"
        .[A6] = "Subject"
        .[B6] = "Page(s)"
        .Range("A1:B1").ColumnWidth = Array(36, 12)
    End With

    TOCRow = 7: PageCount = 0

    msg = "Excel needs to do a print preview to calculate the number of pages." & vbCrLf & "Please dismiss the print preview by clicking close."

    MsgBox msg

    SelSheets.PrintPreview

    For Each S In SelSheets
        With S
            HPages = .HPageBreaks.Count + 1
            VPages = .VPageBreaks.Count + 1
            ThisPages = HPages * VPages

            WST.Range("A" & TOCRow).Value = .Name
            WST.Range("B" & TOCRow).NumberFormat = "@"

            If ThisPages = 1 Then
                WST.Range("B" & TOCRow).Value = PageCount + 1 & " "
            Else
                WST.Range("B" & TOCRow).Value = PageCount + 1 & " " ' & - " & PageCount + ThisPages
            End If

            PageCount = PageCount + ThisPages
            TOCRow = TOCRow + 1
        End With
    Next S
End Sub

編集：1つの重要なこと。OPTION EXPLICIT を使用することは常に良いことです:)

于 2012-05-18T15:24:09.073 に答える
0 
Dim wks as Worksheet, strName as String

For each wks in SelSheets
     strName = strName & wks.Name & ","
Next

strName = Left(strName, Len(strName) -1)

Dim arrWks() as String
arrWks = Split(strName,",")

End Sub

選択したすべてのシートが arrWks に名前で表示され、処理できます。また、ループ内で各シート名をコレクションに追加して、スムーズにすることもできます。

ActiveSheet にはできるだけ近づかないことをお勧めします。このようにして、カウンターとプロセスを使用して配列をループできます

そう：

Dim intCnt as Ingeter
For intCnt = Lbound(arrWks) to UBound(arrWks)
     Worksheets(arrWks(intCnt)).Activate
     .... rest of code .... 
Next

置き換えます

For Each S In SelSheets
于 2012-05-18T14:56:45.190 に答える
0

各シートへの参照を保存できます。

function getSheetsSnapshot() as Worksheet()
dim shts() As Worksheet, i As long
redim shts(ActiveWindow.SelectedSheets.Count - 1)
for i = 0 to ActiveWindow.SelectedSheets.Count - 1
    set shts(i) = ActiveWindow.SelectedSheets(i + 1)
next
getSheetsSnapshot = shts
end function

それらを取得して保存します：

dim oldsel() as Worksheet: oldsel = getSheetsSnapshot()

自分の作業を行ってから、選択した元のシートを参照してください。

for i = 0 to ubound(oldsel)
    msgbox oldsel(i).name
next
于 2012-05-18T15:00:01.423 に答える