Skip to content

Instantly share code, notes, and snippets.

@KotorinChunChun
Created November 2, 2020 12:31
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save KotorinChunChun/7a7b3fdf432a57e8ea49d1fa9bdc9210 to your computer and use it in GitHub Desktop.
Save KotorinChunChun/7a7b3fdf432a57e8ea49d1fa9bdc9210 to your computer and use it in GitHub Desktop.
VBA100本ノック14本目
Option Explicit
'VBA100本ノック14本目
'出題を勘違いして答えた人の末路
Sub vba_knock14()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet
Dim moveWss As Variant: ReDim moveWss(0 To 0) '0はダミー
'削除すべきシートを特定
For Each ws In wb.Worksheets
If Is社外秘(ws) Then
ReDim Preserve moveWss(1 To UBound(moveWss) + 1)
moveWss(UBound(moveWss)) = ws.Name
End If
Next
If LBound(moveWss) = 0 Then Exit Sub
'問題のシートを切り出し
Const DUMMYFN = "DUMMY.xlsx"
With Workbooks.Add
wb.Worksheets(CVar(moveWss)).Move After:=.Worksheets(1)
.SaveAs DUMMYFN
.Close
End With
'リンクの解除
'※たまにExcelが操作不能となる。
Dim 試行回数 As Long: 試行回数 = 0
Do
試行回数 = 試行回数 + 1
Debug.Print "リンクの解除 : " & 試行回数 & "回目"
On Error Resume Next
wb.BreakLink Name:=DUMMYFN, Type:=xlExcelLinks
On Error GoTo 0
DoEvents
If Not ExistsLinkSources(wb, DUMMYFN) Then Exit Do
Loop
'一時ファイルの消去
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
Kill DUMMYFN
End Sub
Function ExistsLinkSources(wb As Workbook, fn As String)
Dim var, v
var = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(var) Then
For Each v In var
If v Like "*" & fn Then ExistsLinkSources = True: Exit Function
Next
End If
End Function
Function Is社外秘(ws As Worksheet)
On Error Resume Next
Dim obj
For Each obj In ws.DrawingObjects
If obj.Text Like "*社*外*秘*" Then
Is社外秘 = True
Exit Function
End If
Next
End Function
'----------------------------------------------------------------------------------------------------
'テスト用データの生成
Sub CreateTestData()
ActiveWorkbook.Worksheets.Add
Call Create社外秘("わーっはっはっは")
ActiveWorkbook.Worksheets.Add
ActiveSheet.Cells(1, 1).Formula = "=" & ActiveSheet.Next.Name & "!A1"
ActiveWorkbook.Worksheets.Add
Call Create社外秘("我は雷・・・神なり")
ActiveWorkbook.Worksheets.Add
ActiveSheet.Cells(1, 1).Formula = "=" & ActiveSheet.Next.Name & "!A1"
End Sub
Sub Create社外秘(A1の文字列)
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 179.25, 131.25, 246.75, 103.5).Select
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "社外秘"
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 48
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 6
End With
Range("C9").Select
ActiveSheet.Cells(1, 1).Value = ActiveSheet.Name & "のコメント:" & A1の文字列
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment