<<ThisWorkBook>>这个文档内容
Public Sub Workbook_Open()
Call CreateToolBar.CreateToolBar
End Sub
<<MoDules>>这个文档内容建一个名为CreateToolBar的module
Option Explicit
Sub CreateToolBar()
Dim newTool As CommandBar
On Error Resume Next
Application.CommandBars("CDC_KANDEN_TOOLBAR").Delete
On Error GoTo 0
Application.CommandBars.Add
Set newTool = Application.CommandBars.Add(Name:="CDC_KANDEN_TOOLBAR")
newTool.Visible = True
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetToA1"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 10
.OnAction = "SetToA1"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetFont"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 401
.OnAction = "SetFont"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetZoom70"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 25
.OnAction = "SetZoom70"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetPrintAreaE"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 84
.OnAction = "SetPrintAreaE"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetHeaderLink"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 43
.OnAction = "SetHeaderLink"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetHeaderSize"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 326
.OnAction = "SetHeaderSize"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetColomnSize"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 970
.OnAction = "SetColomnSize"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SetScrollBar"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 468
.OnAction = "SetScrollBar"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "ResetFormatAll"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 105
.OnAction = "ResetFormatAll"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "OpenFile"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 23
.OnAction = "OpenFile"
End With
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = "SortByCustom"
.Style = msoButtonIcon
.TooltipText = "TooltipText"
.FaceId = 210
.OnAction = "SortByCustom"
End With
End Sub
Sub CreateFaceIdToolBar()
Dim newTool As CommandBar
On Error Resume Next
Application.CommandBars("FaceIdToolbar").Delete
On Error GoTo 0
Application.CommandBars.Add
Set newTool = Application.CommandBars.Add(Name:="FaceIdToolbar")
newTool.Visible = True
Dim i As Integer
For i = 15 To 30
With newTool.Controls.Add(Type:=msoControlButton)
.Caption = i
.Style = msoButtonIconAndCaption
.FaceId = i
End With
Next
End Sub
<<MoDules>>这个文档内容建一个名为OnAction的module
Option Explicit
Sub SetToA1()
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("カーソルの位置を「A1」に移動してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetToA1OfOneSheet
Next
Sheets(1).Activate
Application.ScreenUpdating = True
End If
If btn = vbNo Then
Call SetToA1OfOneSheet
End If
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetFont()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("フォントは「Meiryo UI」を設定してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Set currSheet = ActiveSheet
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetFontOfOneSheet
Call SetObjectFontOfOneSheet
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
Call SetFontOfOneSheet
Call SetObjectFontOfOneSheet
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetZoom70()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("ズームを「70％」に設定してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Set currSheet = ActiveSheet
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetZoom70OfOneSheet
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
Call SetZoom70OfOneSheet
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetPrintAreaE()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("印刷範囲の外側に「e」を付けてよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Set currSheet = ActiveSheet
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetPrintAreaEOfOneSheet
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
Call SetPrintAreaEOfOneSheet
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetHeaderLink()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
Dim allAddress() As String
btn = MsgBox("ヘッダ情報を反映してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If Sheets.Count = 1 Then
MsgBox ("１シートのみ存在していますので、処理中止します。")
Exit Sub
End If
allAddress = GetHeaderLinkAddress
If btn = vbYes Then
Set currSheet = ActiveSheet
Dim cnt As Integer
cnt = 1
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
If sh.Name <> Sheets(1).Name Then
Dim sheetFrom As Worksheet
Dim startAddressFrom As String
Dim endAddressFrom As String
Dim sheetTo As Worksheet
Dim startAddressTo As String
Dim endAddressTo As String
If cnt = 1 Then
Call SetHeaderLinkOfOneSheet(allAddress(0), allAddress(1), allAddress(2), allAddress(3), allAddress(4), allAddress(5), allAddress(6), allAddress(7), allAddress(8), allAddress(9))
Set sheetFrom = ActiveSheet
startAddressFrom = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").address(0, 0)
endAddressFrom = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)
End If
If cnt >= 2 Then
Set sheetTo = ActiveSheet
startAddressTo = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").address(0, 0)
endAddressTo = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)
End If
If cnt = 2 Then
sheetFrom.Activate
sheetFrom.Range(startAddressFrom & ":" & endAddressFrom).Select
Selection.Copy
End If
If cnt >= 2 Then
sheetTo.Activate
ActiveSheet.Range(startAddressTo & ":" & endAddressTo).Select
ActiveSheet.Paste
End If
cnt = cnt + 1
End If
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
If ActiveSheet.Name <> Sheets(1).Name Then
Call SetHeaderLinkOfOneSheet(allAddress(0), allAddress(1), allAddress(2), allAddress(3), allAddress(4), allAddress(5), allAddress(6), allAddress(7), allAddress(8), allAddress(9))
Else
MsgBox ("「" & Sheets(1).Name & "」以外のシートを選択してください。")
End If
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetHeaderSize()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
Dim allAddress() As String
btn = MsgBox("全シートのヘッダオブジェクトのサイズを統一してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If Sheets.Count = 1 Then
MsgBox ("１シートのみ存在していますので、処理中止します。")
Exit Sub
End If
Set currSheet = ActiveSheet
Dim firstSheet As Worksheet
Dim left As Single, top As Single, width As Single, height As Single
Set firstSheet = Sheets(1)
firstSheet.Activate
Dim shp As Shape
For Each shp In firstSheet.Shapes
shp.Select
Dim formula As String
On Error Resume Next
formula = Selection.formula
On Error GoTo 0
If formula <> "" Then
With Selection.ShapeRange
left = .left
top = .top
width = .width
height = .height
End With
Exit For
End If
Next shp
currSheet.Select
If btn = vbYes Then
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
If sh.Name <> Sheets(1).Name Then
Call SetHeaderSizeOfOneSheet(left, top, width, height)
End If
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
If ActiveSheet.Name <> Sheets(1).Name Then
Call SetHeaderSizeOfOneSheet(left, top, width, height)
Else
MsgBox ("「" & Sheets(1).Name & "」以外のシートを選択してください。")
End If
End If
Set currSheet = Nothing
Set sh = Nothing
Set firstSheet = Nothing
MsgBox ("Finished")
End Sub
Sub SetColomnSize()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("列の幅を調整してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Set currSheet = ActiveSheet
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetColomnSizeOfOneSheet
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
Call SetColomnSizeOfOneSheet
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub SetScrollBar()
Dim currSheet As Worksheet
Dim sh As Worksheet
Dim btn As Long
btn = MsgBox("スクロールバーを初期化してよろしいでしょうか？" & vbCrLf & vbCrLf & _
"全シート：「はい」を押してください。" & vbCrLf & _
"当シート：「いいえ」を押してください。" & vbCrLf, _
vbYesNoCancel)
If btn = vbCancel Then
Exit Sub
End If
If btn = vbYes Then
Set currSheet = ActiveSheet
Application.ScreenUpdating = False
For Each sh In Sheets
sh.Activate
Call SetScrollBarOfOneSheet
Next
Application.ScreenUpdating = True
currSheet.Select
End If
If btn = vbNo Then
Call SetScrollBarOfOneSheet
End If
Set currSheet = Nothing
Set sh = Nothing
MsgBox ("Finished")
End Sub
Sub OpenFile()
Dim selectItem As Variant
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx;*.xlsm"
If .Show = -1 Then
For Each selectItem In .SelectedItems
Workbooks.Open fileName:=selectItem, Password:="kanden"
Next
End If
End With
End Sub
Sub SortByCustom()
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim rangex As Range
Dim x
Dim strArray() As String
Dim i As Integer
On Error Resume Next
On Error GoTo 0
Set x = Application.InputBox("基準を選択してください。", "範囲選択", Type:=8)
If VarType(x) = vbBoolean Then
Exit Sub
End If
Set range1 = x
Set x = Application.InputBox("範囲を選択してください。", "範囲選択", Type:=8)
If VarType(x) = vbBoolean Then
Exit Sub
End If
Set range2 = x
Set x = Application.InputBox("キーを選択してください。", "範囲選択", Type:=8)
If VarType(x) = vbBoolean Then
Exit Sub
End If
Set range3 = x
i = 0
ReDim strArray(range1.Count - 1)
For Each rangex In range1
strArray(i) = rangex.Value
i = i + 1
Next
ActiveSheet.sort.SortFields.Clear
ActiveSheet.sort.SortFields.Add Key:=range3, _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Join(strArray, ","), DataOption:=xlSortTextAsNumbers
With ActiveSheet.sort
.SetRange range2
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
MsgBox ("Finished")
End Sub
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
Sub SetToA1OfOneSheet()
Application.Goto ActiveSheet.Cells(1, 1), True
End Sub
Sub SetFontOfOneSheet()
Cells.Font.Name = "Meiryo UI"
End Sub
Sub SetObjectFontOfOneSheet()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Select
On Error Resume Next
With Selection.ShapeRange.TextFrame2.TextRange.Font
.NameComplexScript = "Meiryo UI"
.NameFarEast = "Meiryo UI"
.Name = "Meiryo UI"
End With
On Error GoTo 0
Next shp
End Sub
Sub SetZoom70OfOneSheet()
ActiveWindow.Zoom = 70
End Sub
Sub SetPrintAreaEOfOneSheet()
'開始行
Dim startRow As Long
'最終行
Dim lastRow As Long
'開始列
Dim startCol As Long
'最終列
Dim lastCol As Long
With Range(ActiveSheet.PageSetup.PrintArea)
'印刷範囲の開始行、最終行を取得
startRow = .Rows.Row
lastRow = startRow + .Rows.Count
'印刷範囲の開始列、最終列を取得
startCol = .Columns.Column
lastCol = startCol + .Columns.Count
End With
ActiveSheet.Range(ActiveSheet.Cells(lastRow, startCol), ActiveSheet.Cells(lastRow, lastCol)).Value = "e"
ActiveSheet.Range(ActiveSheet.Cells(startRow, lastCol), ActiveSheet.Cells(lastRow, lastCol)).Value = "e"
End Sub
Function GetHeaderLinkAddress() As String()
Dim deliverAddress As String
Dim detailAddress As String
Dim projectIdAddress As String
Dim teamAddress As String
Dim identifierAddress As String
Dim updaterAddress As String
Dim authorizerAddress As String
Dim updatedDayAddress As String
Dim approvalDayAddress As String
Dim address(9) As String
Dim sh As Worksheet
Set sh = Sheets(1)
deliverAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("成果物名").Offset(0, 1).address(0, 0)
detailAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("詳細").Offset(0, 1).address(0, 0)
projectIdAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("プロジェクト文章ID").Offset(0, 1).address(0, 0)
teamAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("チーム分類").Offset(0, 1).address(0, 0)
identifierAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("文章識別子").Offset(0, 1).address(0, 0)
updaterAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終更新者").Offset(1, 0).address(0, 0)
authorizerAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終承認者").Offset(1, 0).address(0, 0)
updatedDayAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終更新日").Offset(1, 0).address(0, 0)
approvalDayAddress = sh.Range(sh.Cells(1, 1), sh.Cells(10, 500)).Find("最終承認日").Offset(1, 0).address(0, 0)
address(0) = sh.Name
address(1) = deliverAddress
address(2) = detailAddress
address(3) = projectIdAddress
address(4) = teamAddress
address(5) = identifierAddress
address(6) = updaterAddress
address(7) = authorizerAddress
address(8) = updatedDayAddress
address(9) = approvalDayAddress
GetHeaderLinkAddress = address
Set sh = Nothing
End Function
Sub SetHeaderLinkOfOneSheet(sheet_name As String _
, deliver As String _
, detail As String _
, projectId As String _
, team As String _
, identifier As String _
, updater As String _
, authorizer As String _
, updated_day As String _
, approval_day As String)
Dim deliver_row As Integer
Dim deliver_col As Integer
Dim detail_row As Integer
Dim detail_col As Integer
Dim detail_col2 As Integer
Dim projectId_row As Integer
Dim projectId_col As Integer
Dim team_row As Integer
Dim team_col As Integer
Dim identifier_row As Integer
Dim identifier_col As Integer
Dim updater_row As Integer
Dim updater_col As Integer
Dim authorizer_row As Integer
Dim authorizer_col As Integer
Dim updated_day_row As Integer
Dim updated_day_col As Integer
Dim approval_day_row As Integer
Dim approval_day_col As Integer
'成果物名
deliver_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").Row
deliver_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("成果物名").Column
If deliver_row <> 0 Then
deliver_col = deliver_col + 7
ActiveSheet.Cells(deliver_row, deliver_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(deliver_row, deliver_col).Value = "='" & sheet_name & "'!" & deliver
Else
MsgBox "「成果物名」という文字が見つかりません"
End If
'詳細名
detail_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("詳細").Row
detail_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("詳細").Column
If detail_row <> 0 Then
detail_col = detail_col + 7
detail_col2 = detail_col + 26
ActiveSheet.Cells(detail_row, detail_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(detail_row, detail_col).Value = "='" & sheet_name & "'!" & detail
ActiveSheet.Cells(detail_row, detail_col2).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(detail_row, detail_col2).Value = "=MID(CELL(""filename"",$A$2),FIND(""]"",CELL(""filename"",$A$2))+1,31)"
Else
MsgBox "「詳細」という文字が見つかりません"
End If
'プロジェクト文章ID
projectId_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("プロジェクト文章ID").Row
projectId_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("プロジェクト文章ID").Column
If projectId_row <> 0 Then
projectId_col = projectId_col + 7
ActiveSheet.Cells(projectId_row, projectId_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(projectId_row, projectId_col).Value = "='" & sheet_name & "'!" & projectId
Else
MsgBox "「プロジェクト文章ID」という文字が見つかりません"
End If
'チーム分類
team_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("チーム分類").Row
team_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("チーム分類").Column
If team_row <> 0 Then
team_col = team_col + 7
ActiveSheet.Cells(team_row, team_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(team_row, team_col).Value = "='" & sheet_name & "'!" & team
Else
MsgBox "「チーム分類」という文字が見つかりません"
End If
'文章識別子
identifier_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("文章識別子").Row
identifier_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("文章識別子").Column
If identifier_row <> 0 Then
identifier_col = identifier_col + 7
ActiveSheet.Cells(identifier_row, identifier_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(identifier_row, identifier_col).Value = "='" & sheet_name & "'!" & identifier
Else
MsgBox "「文章識別子」という文字が見つかりません"
End If
'最終更新者
updater_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新者").Row
updater_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新者").Column
If updater_row <> 0 Then
updater_row = updater_row + 1
ActiveSheet.Cells(updater_row, updater_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(updater_row, updater_col).Value = "='" & sheet_name & "'!" & updater
Else
MsgBox "「最終更新者」という文字が見つかりません"
End If
'最終承認者
authorizer_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認者").Row
authorizer_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認者").Column
If authorizer_row <> 0 Then
authorizer_row = authorizer_row + 1
ActiveSheet.Cells(authorizer_row, authorizer_col).NumberFormatLocal = "G/標準"
ActiveSheet.Cells(authorizer_row, authorizer_col).Value = "='" & sheet_name & "'!" & authorizer
Else
MsgBox "「最終承認者」という文字が見つかりません"
End If
'最終更新日
updated_day_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Row
updated_day_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Column
If updated_day_row <> 0 Then
updated_day_row = updated_day_row + 1
ActiveSheet.Cells(updated_day_row, updated_day_col).NumberFormatLocal = "yyyy/mm/dd"
ActiveSheet.Cells(updated_day_row, updated_day_col).Value = "='" & sheet_name & "'!" & updated_day
Else
MsgBox "「最終更新日」という文字が見つかりません"
End If
'最終承認日
approval_day_row = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Row
approval_day_col = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終承認日").Column
If approval_day_row <> 0 Then
approval_day_row = approval_day_row + 1
ActiveSheet.Cells(approval_day_row, approval_day_col).NumberFormatLocal = "yyyy/mm/dd"
ActiveSheet.Cells(approval_day_row, approval_day_col).Value = "='" & sheet_name & "'!" & approval_day
Else
MsgBox "「最終承認日」という文字が見つかりません"
End If
End Sub
Sub SetHeaderSizeOfOneSheet(left As Single, top As Single, width As Single, height As Single)
'全シートループ
Dim adjusted As Boolean
Dim formula As String
'位置未調整
adjusted = False
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Select
On Error Resume Next
formula = Selection.formula
On Error GoTo 0
If formula <> "" Then
' 位置調整
With Selection.ShapeRange
.lockAspectRatio = msoFalse
.height = height
.width = width
.left = left
.top = top
End With
'位置調整済
adjusted = True
End If
'位置調整済なら、オートシェイプのループを抜ける
If adjusted = True Then
Exit For
End If
Next shp
End Sub
Sub SetColomnSizeOfOneSheet()
If ActiveSheet.Name = "更新履歴" Then
Columns("A:A").ColumnWidth = 2.38
Columns("B:B").ColumnWidth = 5.13
Columns("C:C").ColumnWidth = 50.13
Columns("D:D").ColumnWidth = 15.63
Columns("E:E").ColumnWidth = 40.13
Columns("F:F").ColumnWidth = 15.63
Columns("G:G").ColumnWidth = 40.13
Columns("H:H").ColumnWidth = 4.5
Columns("I:I").ColumnWidth = 8.25
Columns("J:J").ColumnWidth = 8.25
Range(Columns("K:K"), Columns("AC:AC").End(xlToRight)).ColumnWidth = 2
Else
Columns("A:A").ColumnWidth = 1.88
Columns("B:AB").ColumnWidth = 8.25
Range(Columns("AC:AC"), Columns("AC:AC").End(xlToRight)).ColumnWidth = 2
End If
End Sub
Sub SetScrollBarOfOneSheet()
'開始行
Dim startRow As Long
'最終行
Dim lastRow As Long
Dim updatedDayAddress As String
With Range(ActiveSheet.PageSetup.PrintArea)
'印刷範囲の開始行、最終行を取得
startRow = .Rows.Row
lastRow = startRow + .Rows.Count
End With
updatedDayAddress = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(10, 500)).Find("最終更新日").Offset(0, 2).address(0, 0)
updatedDayAddress = Mid(updatedDayAddress, 1, 2)
Rows(lastRow + 1 & ":" & "1048576").Delete Shift:=xlUp
Columns(updatedDayAddress & ":" & "XFD").Delete Shift:=xlToLeft
End Sub
Sub ResetFormatAll()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim start_row_number As Integer
Dim end_row_number As Integer
Application.ScreenUpdating = False
start_row_number = Selection.Row
end_row_number = start_row_number + Selection.Rows.Count - 1
For i = end_row_number To start_row_number Step -1
If Cells(i, 2) Like "TABLE=*" Then
Dim table_end_row_number As Integer
Dim table_end_column_number As Integer
table_end_row_number = end_row_number
table_end_column_number = 16384
For j = i + 5 To end_row_number
If Cells(j, 2) = "" Or Cells(j, 2) Like "TABLE=*" Then
table_end_row_number = j - 1
Exit For
End If
Next
For k = 2 To 16384
If Cells(i + 2, k) = "" Or Cells(i + 2, k) = "e" Then
If Cells(i + 2, k) = "" And Cells(i + 1, k) <> "" Then
MsgBox ("漢字名が漏れた")
Application.Goto Cells(i + 2, k)
Exit Sub
End If
table_end_column_number = k - 1
Exit For
End If
Next
Range(Cells(i, 2), Cells(table_end_row_number, table_end_column_number)).Select
Call reset_format
End If
Next
MsgBox ("ok")
End Sub
Sub reset_format()
Dim start_row_number As Integer
Dim end_row_number As Integer
Dim start_column_number As Integer
Dim end_column_number As Integer
Dim column_count As Integer
Dim m As Integer
Dim this_book_nm As String
Dim this_sheet_nm As String
start_row_number = Selection.Row
end_row_number = start_row_number + Selection.Rows.Count - 1
column_count = Selection.Rows.Count
start_column_number = Selection.Column
end_column_number = start_column_number + Selection.Columns.Count - 1
this_book_nm = ActiveWorkbook.Name
this_sheet_nm = ActiveSheet.Name
Selection.Font.Bold = False
Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Value = Replace(Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Text, "TABLE=", "") & "（" & Replace(Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 4).Text, "//", "") & "）"
Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Font.Name = "Meiryo UI"
Workbooks(this_book_nm).Sheets(this_sheet_nm).Cells(start_row_number, 2).Font.Bold = True
Workbooks(this_book_nm).Sheets(this_sheet_nm).Range(Cells(start_row_number, 3), Cells(start_row_number, 6)).ClearContents
Rows((start_row_number + 3) & ":" & (start_row_number + 4)).Delete Shift:=xlUp
Range(Cells(start_row_number, 2), Cells(end_row_number - 2, end_column_number)).Select
start_row_number = Selection.Row
end_row_number = start_row_number + Selection.Rows.Count - 1
column_count = Selection.Rows.Count
start_column_number = Selection.Column
end_column_number = start_column_number + Selection.Columns.Count - 1
Dim last_row As Integer
Dim last_column As Integer
Dim cnt As Integer
Dim c_au_colunm As Integer
last_row = start_row_number + 1
last_column = end_column_number
cnt = 1
c_au_colunm = 26
While last_column > c_au_colunm
Call insert_blank_rows(last_row + column_count - 1, column_count - 1)
Call set_many_rows(last_row, c_au_colunm + 1, start_row_number - 1 + cnt * column_count, last_column, start_row_number - 1 + cnt * column_count + 2)
last_row = start_row_number - 1 + cnt * column_count + 2
last_column = last_column - c_au_colunm + 1
cnt = cnt + 1
Wend
End Sub
网友评论