VBA100本ノックチャレンジ：11～20本目

Yuzunoki

だんだん難しくなってきた。

11本目。

Public Sub VBA100本ノック_011()

   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Dim rw As Long
   For rw = 2 To ws.Range("A1").End(xlDown).Row
       With ws.Cells(rw, 3)
           If .MergeCells Then
               If .Address = .MergeArea.Item(1).Address Then
                   .AddComment "結合されたセルです。"
                   .Comment.Visible = True
               End If
           End If
       End With
   Next

End Sub

VBAでコメント入力する機会があんまりなかったので自動メンバ表示に頼りました。

12本目。

Public Sub VBA100本ノック_012()

   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Dim rw As Long
   For rw = 2 To ws.Range("A1").End(xlDown).Row
       With ws.Cells(rw, 3).MergeArea
           If .Count > 1 Then
               .UnMerge
               
               Dim myInt As Long
               myInt = Int(.Item(1).Value / .Count)
               
               Dim myMod As Long
               myMod = .Item(1).Value Mod .Count
               
               .Value = myInt
               If myMod > 0 Then
                   .Resize(myMod, 1).Value = myInt + 1
               End If
           End If
       End With
   Next

End Sub

＜失念ポイント＞「入っている金額を整数で均等に割り振ってください。」を読み損ねていて、最初普通に「.Value = .Item(1).Value / .Count」にしてしまっていた。ちゃんと問題文を読まない。反省。

13本目。

Public Sub VBA100本ノック_013()

   Const Keyword As String = "注意"

   If LCase(TypeName(Selection)) = "range" Then
       Dim r As Range
       For Each r In Selection
           If Not r.HasFormula Then
               Dim buf As String
               buf = r.Value
               
               Dim cnt As Long
               cnt = 0
               
               Do
                   Dim iStart As String
                   iStart = InStr(buf, Keyword)
                   If iStart = 0 Then
                       Exit Do
                   End If
                   
                   cnt = cnt + iStart
                   With r.Characters(cnt, Len(Keyword)).Font
                       .ColorIndex = 3
                       .Bold = True
                   End With
                   
                   buf = Right(buf, Len(buf) - cnt)
               Loop
           End If
       Next
   End If

End Sub

＜失念ポイント①＞TypeNameをあまり使ってなくて忘れていたのでググった。
＜失念ポイント②＞一部分だけFontを変えるやり方を忘れていたのでマクロ記録で確認した。
＜失念ポイント③＞最初、HasFormulaで数式セルを対象外にしていなかった。
＜失念ポイント④＞InStrはスタート位置を指定できるが、普段使っていないので忘れていた（だからbufでずらしていた）。「Instr(iStart, buf, Keyword)」ってすれば一発だった。
失念ポイントが多い！あとここら辺から「問題文には書いてないけど考えなければならないこと（今回で言うHasFormulaなど）」でこける箇所が続出する。難しい。

14本目。

Public Sub VBA100本ノック_014()

   Const Keyword As String = "社外秘"

   Dim wb As Workbook
   Dim ws As Worksheet
   
   For Each ws In ThisWorkbook.Worksheets
       Dim IsVisible As Boolean
       IsVisible = ws.Visible
       
       ws.Visible = xlSheetVisible
       
       If InStr(ws.Name, Keyword) = 0 Then
           If wb Is Nothing Then
               ws.Copy
               Set wb = ActiveWorkbook
           Else
               ws.Copy after:=wb.Worksheets(wb.Worksheets.Count)
           End If
           
           With ActiveSheet
               .Cells.UnMerge
               
               ws.Cells.Copy
               .Cells.PasteSpecial xlPasteValues
               .Cells.PasteSpecial xlPasteFormats
               Application.CutCopyMode = False
           End With
       End If
       
       ws.Visible = IsVisible
   Next
   
   If Not wb Is Nothing Then
       wb.SaveAs ThisWorkbook.Path & "\送付用ブック.xlsx"
       wb.Close
   End If

End Sub
#VBA100本ノック 14本目 解答
考え方中心に、
要点
・客先へ送付
・社外秘シートの削除
・値貼り付け
注意点
・シート削除の前に値貼り付けする
・シート削除できない場合がある
後者の件
・表示シートが無くなる
・xlSheetVeryHidden
最後に、非表示シートのまま内容確認しなくて良いのでしょうか?

スレッドを見ていると上記引用のようなことが書かれていたのでプチパニック。つまりどうすればいいのか？客先に送付するファイルと考えると拡張子もxlsmでないほうがいい？非表示シートをどうするかは事前に確認しなければならないとしてこの場は？と足掻いた結果は上のコードのとおり。動きはする、するけれども…しっくりこない。

答えをざっと見る。手動更新になっていたときのためにいったん全シート再計算するとか、別にxlsmのままでよかったのかとか、気づかなかったことやそこは考えなくてもいいの？というところまで、個人的には少し釈然としない部分も。とりあえず気づかなかったところには今後気付けるようにしていきます。書き直したコードは以下。

Public Sub VBA100本ノック_014other()

   Const Keyword As String = "社外秘"
   
   Dim wb As Workbook
   Dim ws As Worksheet
   
   Dim myCalc As Variant
   myCalc = Application.Calculation
   Application.Calculation = xlCalculationAutomatic
   Application.Calculation = myCalc
   
   For Each ws In ActiveWorkbook.Worksheets
       ws.UsedRange.Value = ws.UsedRange.Value
   Next

   For Each ws In ActiveWorkbook.Worksheets
       If InStr(ws.Name, Keyword) > 0 Then
           Application.DisplayAlerts = False
           ws.Delete
           Application.DisplayAlerts = True
       End If
   Next

End Sub

15本目。

Public Sub VBA100本ノック_015()
   
   Dim wb As Workbook
   Set wb = ThisWorkbook
   
   Dim wsTemp As Worksheet
   wb.Worksheets.Add
   Set wsTemp = ActiveSheet
   
   With wsTemp
       .Cells(1, 1).Value = "sort"
       
       Dim ws As Worksheet
       For Each ws In wb.Worksheets
           If ws.Name <> .Name Then
               .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = CDate(ws.Name & "1日")
           End If
       Next
   
       .Sort.SortFields.Clear
       .Sort.SortFields.Add Key:=.Cells(1, 1), Order:=xlAscending
       .Sort.SetRange .Cells(1, 1).CurrentRegion
       .Sort.Header = xlYes
       .Sort.Apply
       
       Dim i As Long
       Dim buf As String
       For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
           buf = Format(.Cells(i, 1).Value, "yyyy年mm月")
           wb.Worksheets(buf).Move before:=wb.Worksheets(i - 1)
       Next
       
       Application.DisplayAlerts = False
       .Delete
       Application.DisplayAlerts = True
   End With
   
   wb.Saved = True
   
End Sub

＜失念ポイント＞「バブルソート」、発想はあったのにやり方をそれこそ失念していて落とし込めなかった。たいへん悔しい思いをしながらも、ググらずに何とか対応したのが上記コード。書き方は後ほど回答を確認した。

16本目。

Public Function VBA100本ノック_016(buf As String) As String

   buf = Replace(buf, vbCrLf, vbLf)
   
   Do Until Len(buf) = Len(Replace(buf, vbLf & vbLf, vbLf))
       buf = Replace(buf, vbLf & vbLf, vbLf)
   Loop
   
   If Left(buf, 1) = vbLf Then
       buf = Right(buf, Len(buf) - 1)
   End If
   
   If Right(buf, 1) = vbLf Then
       buf = Left(buf, Len(buf) - 1)
   End If
   
   VBA100本ノック_016 = buf

End Function

＜失念ポイント＞正規表現（RegExp）、使ったことはあるのにこういう場面で使う発想がなかった。回答を見て大変便利だとまざまざ思い知る。

17本目。

Public Sub VBA100本ノック_017()

   Dim wsList As Worksheet
   Dim wsMasta As Worksheet
   
   With ThisWorkbook
       Set wsList = .Worksheets("社員")
       Set wsMasta = .Worksheets("部・課マスタ")
   End With

   wsList.Columns("C:F").Copy wsMasta.Columns("A")
   Application.CutCopyMode = False
   
   With wsMasta
       .Range("A1").CurrentRegion.RemoveDuplicates Columns:=2, Header:=xlYes
       .Sort.SortFields.Clear
       .Sort.SortFields.Add Key:=.Range("B1"), Order:=xlAscending
       .Sort.SetRange .Range("A1").CurrentRegion
       .Sort.Header = xlYes
       .Sort.Apply
   End With
   
End Sub

RemoveDuplicatesは少し前にWinActorのライブラリ修正関係で目にしたので使ってみたかった。Dictionaryなどでユニーク化した方がいいのは分かる。System.Collections.ArrayListだとソートが使えるけどDictionaryは標準搭載されていないので、クイックソート使うとか。アルゴリズムに弱いので、私はクイックソートとかちゃんと勉強した方がいい。

18本目。

Public Sub VBA100本ノック_018()

   Dim cntDelete As Long
   Dim cntHidden As Long
   
   Dim n As Name
   For Each n In ThisWorkbook.Names
       If n.Visible = False Then
           cntHidden = cntHidden + 1
       End If
       
       If InStr(UCase(n.RefersTo), "#REF!") > 0 Then
           Debug.Print "名前："; n.Name; "／参照範囲："; n.RefersTo
           cntDelete = cntDelete + 1
           n.Delete
       End If
   Next
   
   MsgBox "非表示件数：" & cntHidden & "件" & vbCrLf & _
          "削除件数：" & cntDelete & "件"
   
End Sub

おおむねそのまま。たぶん。

Public Sub VBA100本ノック_019(ws As Worksheet)
' ※これは意図に添わない間違ったコードです（後述）※
   ws.Shapes.SelectAll
   
   Dim obj1 As Object
   Set obj1 = Selection.Group
   obj1.Copy
   ws.Paste
   
   Dim obj2 As Object
   Set obj2 = Selection
   obj2.Top = obj1.Top
   obj2.Left = obj1.Left + obj2.Width
   
   obj1.Ungroup
   obj2.Ungroup
   ws.Range("A1").Activate
   
End Sub

ここで死ぬほど詰まった。
普段Shapesとか全然使わないのはもとより、問題文の「繰り返し実行しても増殖しないように工夫する。」の意図がちゃんと掴めなくて混乱してしまった。答えを見ないようにしていたのが仇になって、いったん上記コードを書き終えた後スレッドを見たら、質問されている方がいらした。「図形コピーする前に、VBAでコピー作成した図形は削除するという事です。」とのこと。という訳でこのコードは意図に添わない間違ったコードです。

書き直したものがこちら。

Public Sub VBA100本ノック_019Ans(ws As Worksheet)

   Const Keyword As String = "VBA100本ノック_019Ans"

   Dim shp As Shape
   
   For Each shp In ws.Shapes
       If InStr(shp.Name, Keyword) > 0 Then
           shp.Delete
       End If
   Next
   
   Dim shp2 As Shape
   For Each shp In ws.Shapes
       If shp.Type <> msoFormControl Then
           Set shp2 = shp.Duplicate
           shp2.Name = Keyword & shp2.Name
           shp2.Top = shp.Top
           shp2.Left = shp.Left + shp2.Width
       End If
   Next

End Sub

Duplicateとか使ったことなかった。便利。

20本目。

Public Sub VBA100本ノック_020()
   
   Dim oFSO As Object
   Set oFSO = CreateObject("Scripting.FileSystemObject")

   Dim sBackupFolder As String
   sBackupFolder = oFSO.BuildPath(ThisWorkbook.Path, "BACKUP")
   If Dir(sBackupFolder, vbDirectory) = "" Then
       MkDir sBackupFolder
   End If
   
   Dim cnt As Long
   Dim sNumber As String
   Dim sName As String
   Dim sDstPath As String
   
   Do
       cnt = cnt + 1
       If cnt = 1 Then
           sNumber = ""
       Else
           sNumber = "(" & cnt & ")"
       End If
       sName = oFSO.GetBaseName(ThisWorkbook.Name) & "_" & Format(Now, "yyyymmddhhmm") & sNumber & oFSO.GetExtensionName(ThisWorkbook.Name)
       sDstPath = oFSO.BuildPath(sBackupFolder, sName)
   
   Loop While oFSO.FileExists(sDstPath)
   
   oFSO.CopyFile ThisWorkbook.FullName, sDstPath
   
End Sub

実家のような安心感（FSO）（最近ExcelVBA書くよりWinActorライブラリ＝VBScriptを見る方が多いので…）
他の方の回答を見ると、「IIf」というものを発見。Accessクエリで試行錯誤してる時に見た。見たけど使い方がいまいち身についていなかった模様。改めて見るとすごく便利。覚えました。
「sNumber = iif(cnt = 1,"","(" & cnt & ")")」で済む…便利…。
また、他の回答を見ると保存数制限も考えた方がいいのでは？ということでDoLoopではなくForNextで連番付与していた。ここもまだまだ考え足りないのか…。

■20本目を終えて

VBAの知識以前に自分に足りないところがところどころ掘り起こされた。課題の読み不足や、状況に対する想像不足（経験不足も一因ではあると思う）。

自動化って難しい。どうすればよいコードになるのか、まだまだ全然分からない。