[英]Inserting the value in A1 of each worksheet in the WorkBook into column B of the Table of Contents
我創建了一個 VBA 宏來在每次選擇目錄時創建一個刷新目錄工作表。 （我從我在網上找到的一個例子中借用了這段代碼，並插入了一條評論以表揚作者。）
該宏在 A 列中插入工作表選項卡名稱，並創建一個超鏈接，當用戶單擊該單元格時選擇該工作表。
該宏還調整行和列的大小，定義字體、字體顏色和字體大小、邊框線寬和顏色並添加此類功能，例如文件名、位置、創建者、創建日期、最后修改器和最后修改日期。
我也無法創建 For 每個循環來訪問除目錄以外的工作表中的單元格 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
我很困惑，以至於我正在發布我嘗試過的任何編碼。 我認為這個問題需要一個新的公正的方法。
謝謝
使用以下代碼：
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
VBA：將數據從源工作簿復制並粘貼到目標工作表如果它們的單元格“A1”值彼此相等
[英]VBA: Copy & Paste data from source workbook to destination worksheet If their Cell "A1" value is equal to each others
如何為工作簿 VBA 中的每個工作表將單元格值定義為同一列
[英]How to define cell values to the same column for each worksheet in the workbook VBA
將值復制並粘貼到工作簿中每個工作表的數據表末尾
[英]copy & paste value to the end of datatable for each worksheet in workbook
匹配工作簿1的A列和工作簿2的A列中的文本，並匹配工作簿2的B列中的值
[英]Match text from workbook 1 column A and workbook 2 column A and return value from column B in Workbook 2
計算A列中的行數，該行數在工作表2的B列的列表中具有值
[英]Count number of rows in column A that have a value in a list in column B on worksheet 2
Excel VBA-循環以過濾表中列中的每個值並粘貼到工作表中
[英]Excel VBA - Loop to filter table for each value in column and paste in according worksheet
循環工作簿中的工作表並將每個工作簿合並到主工作簿中的工作表中
[英]Looping through worksheets in a workbook and consolidating each workbook in to a worksheet in the master workbook
如何將= MATCH（VALUE（A1），VALUE（B：B），0）轉換為VBA代碼
[英]How to convert =MATCH(VALUE(A1), VALUE(B:B), 0) into vba code
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.