Блог

Главная - Вопросы по программированию - Вставка значения в формате A1 каждого листа рабочей книги в столбец B таблицы содержания

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

#excel #vba

#excel #vba

Вопрос:

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

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

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

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

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

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

Спасибо

Комментарии:

1. «Я думаю, что к этой проблеме нужен свежий непредвзятый подход» — всегда лучше, если вы опубликуете свой код и точно опишете, какие проблемы возникли при его изменении. Никто здесь действительно не хочет переписывать ваш рабочий код, чтобы добавить небольшую модификацию.

2. ..если это звучит грубо, это не должно быть так: размещение кода — лучший способ получить ответ здесь. То, что вы хотите, скорее всего, является однострочным дополнением к вашему существующему (рабочему) коду.

Ответ №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:="'" amp; ws.Name amp; "'!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 amp; 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