Вставка значения в A1 каждого рабочего листа в WorkBook в столбец B оглавления

Question

Я создал макрос VBA, чтобы обновлять таблицу содержания каждый раз, когда выбирается содержание.(Я позаимствовал этот код из примера, который нашел в Интернете, и вставил комментарий, чтобы отдать должное автору.)

Макрос вставляет имя вкладки листа в столбец А и создает гиперссылку, которая выбирает этот лист, когдапользователь нажимает на эту ячейку.

Макрос также определяет размеры строк и столбцов, определяет шрифты, цвета и размеры шрифта, вес и цвета линии границы и добавляет такую ​​функцию, как имя файла, местоположение, создатель, дата создания, последний модификатор и последняя дата изменения.

Я не смог создать Для каждого цикла, который обращается к ячейке A1 на листе, отличном от Оглавления, и вставляет значение в листе № в столбце B соответствующей строки,

Sheet Name (Col A)                     Sheet Title (Col B)
Audible
Audible (GW)
Battery Inventory & Useage
Mobile  Devices
Major Household Items
eBay Auction Sales
Red Oak
Plywood Inventory
Storage Locations
Dining Room Wall

Я так растерялся, что выкладываю любую кодировку, которую пробовал.Я думаю, что эта проблема требует нового непредвзятого подхода.

Спасибо

Answer 1

Используйте следующий код:

Option Explicit

Private Sub Worksheet_Activate()

'Runs every time the sheet is activated by the user.

  'Create Table of Contents
  Call TOC_Column_A

End Sub

Sub TOC_Column_A()

'Create Table of Contents on this TOC sheet

Dim ws As Worksheet

Dim wsTOC As Worksheet

Dim i As Long

Dim wsTitle As String


  Application.ScreenUpdating = False

  ActiveSheet.Cells.Font.Name = "Comic Sans MS"

  Rows(1).RowHeight = 30

  Rows(2).RowHeight = 24

  Rows("3:30").RowHeight = 18

  Columns("A").ColumnWidth = 1

  Columns("B").ColumnWidth = 9

  Columns("C").ColumnWidth = 39

  Columns("D").ColumnWidth = 60

  Columns("E").ColumnWidth = 90


  'Set variables

  Const bSkipHidden As Boolean = False 'Change this to True to NOT list hidden sheets

  Const sTitle As String = "C1"

  Const sHeader As String = "B2"

  Set wsTOC = Me 'can change to a worksheet ref if using in a regular code module

  'Clear Cells

  wsTOC.Cells.Clear

  ActiveSheet.Cells.Font.Color = RGB(0, 32, 96)

  ActiveSheet.Cells.Font.Name = "Comic Sans MS"

  'Title
  With wsTOC.Range(sTitle)

    .Value = "Table of Contents"

    .Font.Bold = True

    .Font.Size = .Font.Size + 6

    Range("C1").HorizontalAlignment = xlCenter
    'List header

    ActiveSheet.Range("C2:E2").Select

    With Selection

       .VerticalAlignment = xlCenter

       .HorizontalAlignment = xlCenter

       .Font.Bold = True

       .Font.Size = .Font.Size + 4

    End With

    .Offset(1, -1).Value = "#"

    .Offset(1, 0).Value = "Sheet Name"

    .Font.Size = .Font.Size + 4

    .Offset(1, 1).Value = "Sheet Title"

    .Offset(1, 2).Value = "Notes"


  End With

  With wsTOC.Range(sHeader)

'===================== Begin =====================

'Description:       Adds a new sheet with a Table of Contents that

'                   includes thumbnail image tiles of each sheet

'                   in the workbook.  Each image is a clickable

'                   link to the worksheet.


'Running the macro: The macro runs on the ActiveWorkbook.


'                   Changes cannot be undone, so save a copy

'                   of the file before running.


'Author:            Jon Acampora, Excel Campus

'Source:            https://www.excelcampus.com/vba/table-of-contents-gallery/


    For Each ws In ThisWorkbook.Worksheets

        'Skip TOC sheet

        If ws.Name <> wsTOC.Name Then

          'Skipping hidden sheets can be toggled in the variable above

          If bSkipHidden Or ws.Visible = xlSheetVisible Then

            .Offset(i).Value = i

            wsTOC.Hyperlinks.Add Anchor:=.Offset(i, 1), _

                                  Address:="", _

                                  SubAddress:="'" & ws.Name & "'!A1", _

                                  TextToDisplay:=ws.Name


            i = i + 1

          End If

        End If

    Next ws

'===================== End =====================

    ActiveSheet.Cells.Font.Color = RGB(0, 32, 96)

  End With

  Columns("A:B").EntireColumn.Hidden = True

  Range("c3:E30").Select

  Selection.HorizontalAlignment = xlLeft

  Range("c3:E30").IndentLevel = 1

  Range("C1:E1").Merge

  ActiveCell.Select


  Call Color_Borders

  Call Insert_Copyright

  Call Format_Cols

  ActiveWindow.SmallScroll Up:=36

  Range("D3").Select

  Call Copy_data

End Sub

Sub Color_Borders()
'
' Insert worksheet and cell borders

' 
'

   Dim rng As Range, cel As Range

   Set rng = Range("C3:e30")

   For Each cel In rng

       cel.Borders.Color = RGB(191, 191, 191)

   Next cel


    Range("C1:E30").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    ActiveWindow.SmallScroll Down:=-18

    Range("C1:E1").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlDash

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    Range("C2:E2").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlDash

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .Color = -10477568

        .TintAndShade = 0

        .Weight = xlThick

    End With

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub Insert_Copyright()

'
' Insert Copyright info, etc
'
'

    ActiveWindow.SmallScroll Down:=21

    Range("C32:D32").Select

    ActiveCell.FormulaR1C1 = "Copyright © 2019  - All Rights Reserved."

    Selection.Font.Size = 8

    Range("C32:D32").Select

    Selection.Merge

    With Selection

        .HorizontalAlignment = xlGeneral

        .VerticalAlignment = xlCenter

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .mergeCells = True

    End With

    With Selection

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .WrapText = False

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .mergeCells = True

    End With

    Selection.InsertIndent 1


    Range("C34").Select

    ActiveCell.FormulaR1C1 = "Filename:"

    Range("C35").Select

    ActiveCell.FormulaR1C1 = "Path"

    Range("C36").Select

    ActiveCell.FormulaR1C1 = "Created by:"

    Range("C37").Select

    ActiveCell.FormulaR1C1 = "Created date:"

    Range("C38").Select

    ActiveCell.FormulaR1C1 = "Last modified by:"

    Range("C39").Select

    ActiveCell.FormulaR1C1 = "Last modified date:"

    Selection.InsertIndent 1

    Range("C34:C39").Select

    With Selection

        .HorizontalAlignment = xlRight

        .VerticalAlignment = xlBottom

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 1

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .mergeCells = False

    End With

    Range("D34").Select

    ActiveCell.FormulaR1C1 = "=FileTitle()"

    Range("D35").Select

    ActiveCell.FormulaR1C1 = "=CurrentPathName()"

    Range("D36").Select

    ActiveCell.FormulaR1C1 = "=CreatedBy()"

    Range("D37").Select

    Selection.NumberFormat = "yyyy-mmm-dd (ddd) h:mm AM/PM"

    ActiveCell.FormulaR1C1 = "3/19/2019"

    Range("D38").Select

    ActiveCell.FormulaR1C1 = "=LastModifiedBy()"

    Range("D39").Select

    ActiveCell.FormulaR1C1 = "=LastModifiedDate()"

    Selection.InsertIndent 1

    Range("D34:D39").Select

    With Selection

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 1

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .mergeCells = False

    End With


End Sub

Sub Format_Cols()
'
' Formats columns D & E rows 3 through 30
'
'

    Range("D3:E30").Select

    Selection.NumberFormat = "General"

    With Selection

        .NumberFormat = "General"

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 1

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .mergeCells = False

    End With


End Sub

Sub Copy_data()

' Copy data from Cell A1 in each worksheet to Column B, Row WS Name
'
'
'
Dim i As Long

Dim ws As Worksheet

Dim wsTOC As Worksheet



'Set variables

Const bSkipHidden As Boolean = False 

Set wsTOC = Me 


i = 1

   For Each ws In ThisWorkbook.Worksheets

        'Skip TOC sheet

        If ws.Name <> wsTOC.Name Then

          'Skipping hidden sheets can be toggled in the variable above

          If bSkipHidden Or ws.Visible = xlSheetVisible Then

'  I do not understand how to walk through the workbook sheet by sheet

'  and copy the value in cell A1 into Column B where value

'  in column a of the table of contents = ws.Name

'
            Sheets("Sheet1").Range("A1").Copy 

Destination:=Sheets("Sheet2").Range("B????")


            i = i + 1

          End If

        End If

    Next ws


End Sub