VBA100本ノックチャレンジ：51～60本目

Yuzunoki

ますます苛酷になっていく。

51本目。

Public Sub VBA100本ノック_051()

   Const WSNAME As String = "目次"

   Dim wsResult As Worksheet
   On Error Resume Next
   Set wsResult = ThisWorkbook.Worksheets(WSNAME)
   If Err.Number > 0 Then
       Set wsResult = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
       wsResult.Name = WSNAME
   End If
   wsResult.Range("A:B").Clear
   wsResult.Range("A1:B1").Value = Array("シート名", "総ページ数")
   On Error GoTo 0
   
   Dim ws As Worksheet
   For Each ws In ThisWorkbook.Worksheets
       With wsResult
           With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
               .Value = "'" & WorksheetFunction.Clean(ws.Name)
               If ws.Visible = xlSheetVisible Then
                   wsResult.Hyperlinks.Add Anchor:=.Cells, Address:="", SubAddress:="'" & ws.Name & "'!A1"
                   .Offset(0, 1).Value = ws.PageSetup.Pages.Count
               End If
           End With
       End With
   Next

End Sub

やっていることは概ね外していない（Hyperlinksを使うなど）ものの、「シート名にはシングルコーテーション（'）が使える」という点を失念しているため、これだとシート名に「'」使ってると参照不可になっちゃうのでReplaceでシート名中の「'」を「''」に置き換える必要があります。
（全角の「’」も引っかかるのでこれも同じように対応）

52本目。

Public Sub VBA100本ノック_052()

   Dim wb As Workbook
   Set wb = ThisWorkbook
   
   Dim arSht() As String
   Dim cnt As Long
   cnt = -1
   
   Dim ws As Worksheet
   For Each ws In wb.Worksheets
       If ws.Name Like "*印刷*" Then
           cnt = cnt + 1
           ReDim Preserve arSht(cnt)
           arSht(cnt) = ws.Name
       End If
   Next
   
   If cnt > -1 Then wb.Sheets(arSht).PrintPreview
   
End Sub

※arShtへの格納方法については後半の設問で別のやり方を学ぶものの、現時点ではこの通りで記載。

「非表示シートを含めるとエラーになる」ということをすっかり忘れているので、非表示シートが含まれていると止まっちゃう中途半端プロシージャ。
この「非表示シート」周りの処理にいつもすっころんでいる気がする……学習していない……由々しき問題。凹みです。

53本目。

Public Sub VBA100本ノック_053()

   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Dim oList As ListObject
   Set oList = ws.ListObjects(1)
   
   With oList
       .Range.AutoFilter Field:=2, Criteria1:="男"
       .Range.AutoFilter Field:=3, Criteria1:="<=" & DateSerial(Year(Date) - 35, 12, 31)
       .Range.AutoFilter Field:=4, Criteria1:="東京都"
       
       .ListColumns(5).Range.Resize(.ListRows.Count - 1, 1).Offset(1, 0).Value = "対象"
       .ShowAutoFilter = False
   End With
   
End Sub

これでもできなくはないですが、「DataBodyRange」使った方がField指定や範囲指定がずっとやりやすそうですよねやっぱり。あれこれするにもやっぱり見出し行除いた範囲になるもの……。

ListObject.DataBodyRange プロパティ (Excel)
テーブルの見出しの行を除く、値の範囲を表す Range オブジェクトを返します。 読み取り専用です。

54本目。

Private Sub Worksheet_Change(ByVal Target As Range)
   
   With Target
       If .Count > 1 Then Exit Sub
       If .Row = 1 Then Exit Sub
       If Me.Cells(1, .Column).Value <> "商品コード" Then Exit Sub
       
       Application.EnableEvents = False
       .NumberFormatLocal = "@"
       
       Dim rngMasta As Range
       Set rngMasta = ThisWorkbook.Worksheets("マスタ").Range("A1").CurrentRegion
           
       On Error Resume Next
       .Font.ColorIndex = xlAutomatic
       .Offset(0, 1).Value = WorksheetFunction.VLookup(.Value, rngMasta, 2, 0)
       .Offset(0, 3).Value = WorksheetFunction.VLookup(.Value, rngMasta, 3, 0)
       If Err.Number > 0 Then
           .Offset(0, 1).ClearContents
           .Offset(0, 3).ClearContents
           .Font.Color = vbRed
       End If
       On Error GoTo 0
       
       Application.EnableEvents = True
   End With
   
End Sub

B列に1セルずつ手入力する想定でしたけど、他のところから複数行分をB列にコピペしてくる場合とかも考えたら「If .Count > 1 Then Exit Sub」で弾かないでTargetに対してFor Eachで処理した方が確実ですよね。
この辺りは「設計」みたいな話もちょっとずつ関わってくるんだろうか。ユーザーの動作について考えなきゃいけない的な……。

※余談※
実務でちょうど「A列へ契約番号をユーザーに入力させるが、重複があるとその後の処理でエラーになるため入力時に重複がある場合はユーザーへ視覚的に通知、修正させる」みたいな入力シートを作成しました。
某ゼミならぬ「100本ノックでやったところだ！」となりつつユーザーの入力や削除が複数行になったときの対応は一応組めましたが、ユーザーに分かりやすいようになっているかは分からないです……。

55本目。

Public Sub VBA100本ノック_055()
   
   Dim pathTest As String
   pathTest = ThisWorkbook.Path & "\test.xlsm"
   If Dir(pathTest) = "" Then Exit Sub
   
   On Error Resume Next
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   
   Dim wbTest As Workbook
   Set wbTest = Application.Workbooks.Open(pathTest)
   
   Dim Ret As Variant
   Ret = Application.Run("'" & wbTest.Name & "'!mult", 2, 10)
   
   wbTest.Close 0
   MsgBox Ret
   
   Application.EnableEvents = True
   Application.ScreenUpdating = True
   
End Sub

まったく同じではないものの、大体解答と同じになっているはず？
表示すべき「結果」がエラーも含むのであれば、MsgBox IIf(Err.Number = 0, Ret, Err.Description)にするとかでしょうか。

56本目。

Public Sub VBA100本ノック_056()
   
   Dim myCalc As XlCalculation
   myCalc = Application.Calculation
   Application.Calculation = xlCalculationManual
       
   Dim oRE As Object
   Set oRE = CreateObject("VBScript.RegExp")
   oRE.Global = True
   
   On Error Resume Next
   Dim rngArea As Range
   Dim ws As Worksheet
   For Each ws In ThisWorkbook.Worksheets
       oRE.Pattern = "('" & ws.Name & "'!|" & ws.Name & "!)"
       
       Set rngArea = Nothing
       Set rngArea = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
       
       If Not rngArea Is Nothing Then
           Dim r As Range
           For Each r In rngArea
               If oRE.Test(r.Formula) Then
                   If Not r.HasArray And Not r.HasSpill Then
                       r.Formula = oRE.Replace(r.Formula, "")
                   End If
               End If
           Next
       End If
   Next
   
   Application.Calculate
   Application.Calculation = myCalc

End Sub

死ぬほど頭を抱えた。しばらく頭を抱えっぱなしだった。

シート名をどうやって抽出するかなという……悩みの末にRegExpでシングルコーテーションで囲まれてるパターンとないパターンを使ったわけですが。
そして解答を見てもたらされる「シート名にvbTab使えるんだ！？」という驚き。使ってみたらなるほど使えるし、問答無用でシート名にシングルコーテーションつくから表記を統一できますね。
自力で気づける範疇なのかこれは……。

57本目。

Public Sub VBA100本ノック_057()
   
   Dim oFSO As Object
   Set oFSO = CreateObject("Scripting.FileSystemObject")
       
   Dim sPath As String
   sPath = ThisWorkbook.Path & "\BACKUP"
   
   Dim oDicTime As Object
   Set oDicTime = CreateObject("Scripting.Dictionary")
   
   Dim oDicPath As Object
   Set oDicPath = CreateObject("Scripting.Dictionary")
   
   Dim f As Object
   For Each f In oFSO.GetFolder(sPath).Files
       Dim dt As Date
       Dim tm As Date
       dt = CDate(Format(f.DateLastModified, "yyyy/mm/dd"))
       tm = CDate(Format(f.DateLastModified, "hh:mm:ss"))
       
       If oDicTime.Exists(dt) Then
           If oDicTime.Item(dt) < tm Then
               oFSO.DeleteFile oDicPath.Item(dt)
               oDicPath.Item(dt) = f.Path
               oDicTime.Item(dt) = tm
           Else
               oFSO.DeleteFile f.Path
           End If
       Else
           oDicTime.Add dt, tm
           oDicPath.Add dt, f.Path
       End If
   Next
   
End Sub

これも解答と同じくDictionary使ったやつですね。その場で比較して削除していくので、削除失敗時（ファイル使用中等）に対応できていないからそこは勿論甘い。
あと2つDictionary使いましたけど、Itemには解答のように配列も指定できるのでそうすれば1つで済んでもっとすっきりしますね。やればやるほど自分の至らなさが浮き彫りで落ち込んでくるな100本ノック……。

58本目。

Public Function VBA100本ノック_058(ByVal ary As Variant, ByVal n As Long) As String
   
   Dim buf As String
   buf = ary(LBound(ary))
   
   Dim i As Long
   For i = LBound(ary) + 1 To UBound(ary)
       buf = buf & IIf(ary(i - 1) + 1 = ary(i), "-", ",") & ary(i)
   Next
   
   Dim arTemp As Variant
   arTemp = Split(buf, ",")
   
   For i = LBound(arTemp) To UBound(arTemp)
       Dim a As Variant
       a = Split(arTemp(i), "-")
       
       If UBound(a) >= n - 1 Then
           arTemp(i) = a(0) & "-" & a(UBound(a))
       Else
           arTemp(i) = Replace(arTemp(i), "-", ",")
       End If
   Next
   
   VBA100本ノック_058 = Join(arTemp, ",")
   
   ' ジャグ配列 http://wisdom.sakura.ne.jp/programming/cs/cs37.html
   
End Function

ジャグ配列とか知りませんでした。
なので力業で、とりあえず前の値+1と今の値が一致したら「-」、それ以外は「,」で区切りつつ並べ、それを「,」でSplitした配列に対して1つずつ「-」で区切ったときに要素数がn以上となれば最小値と最大値を「-」で結んだものを値とし、それ未満の配列は「-」を「,」に置換、最後にJOINで文字列化。
お恥ずかしい話、JOINは前回のノックでちゃんとやったはずなのにしっかりばっちり忘れていました……暗記が死ぬほど苦手を自認しているんですけど単にやる気がないだけなんだろうかもしかして……。

ジャグ配列
配列の中に配列を収めるという概念が存在します
（中略）
この「配列の配列」のことをジャグ配列と呼びます

59本目。

Public Sub VBA100本ノック_059()
   
   On Error Resume Next
   Application.ScreenUpdating = False

   Dim wb As Workbook
   Set wb = ThisWorkbook
   
   Dim arSht(1 To 4) As Variant
   Dim iQ As Long
   Dim ws As Worksheet
   For Each ws In wb.Worksheets
       Select Case Month(CDate(ws.Name & "1日"))
           Case 4 To 6:   iQ = 1
           Case 7 To 9:   iQ = 2
           Case 10 To 12: iQ = 3
           Case 1 To 3:   iQ = 4
       End Select
       
       If Not IsArray(arSht(iQ)) Then
           arSht(iQ) = Array(ws.Name)
       Else
           Dim arTemp As Variant
           arTemp = arSht(iQ)
           ReDim Preserve arTemp(UBound(arTemp) + 1)
           arTemp(UBound(arTemp)) = ws.Name
           arSht(iQ) = arTemp
       End If
   Next
   
   Dim i As Long
   For i = 1 To 4
       wb.Worksheets(arSht(i)).Copy
       
       Dim sFile As String
       Dim cnt As Long: cnt = 0
       Do
           cnt = cnt + 1
           sFile = wb.Path & "\" & i & "Q" & IIf(cnt = 1, "", "(" & cnt & ")") & ".xlsx"
       Loop Until Dir(sFile) = ""
       
       ActiveWorkbook.SaveAs sFile
       ActiveWorkbook.Close 0
   Next
   
   Application.ScreenUpdating = True

End Sub

せっかくなので直前にもやったジャグ配列を使いました！すぐに復習できるのは良いこと。
日付シートがちゃんとしてない場合とか他にもシートがある場合とかいろいろもろもろ考えられていない部分はありますが、もうどこからどこまでが想像力で補えるところなのか、思いつくエラー対策を100本ノックでどんなに長くなってもちゃんと記述するべきなのか、とかちょっと悩んできました。

60本目。

Public Function VBA100本ノック_060(ByVal Arg As String) As String
   
   Const STR_BEFORE As String = "●"
   Const STR_AFTER  As String = "株式会社"
   
   If Len(Arg) = 0 Then Exit Function
   
   Dim i As Long
   For i = 1 To Len(Arg)
       Select Case WorksheetFunction.Unicode(Mid(Arg, i, 1))
           Case 12849, 13183
               Mid(Arg, i, 1) = STR_BEFORE
       End Select
   Next
   
   Dim oRE As Object
   Set oRE = CreateObject("VBScript.RegExp")
   oRE.Pattern = ".{0,1}株.{0,1}"
   oRE.Global = True
       
   Dim m As Object
   For Each m In oRE.Execute(Arg)
       If StrConv(Left(m.Value, 1), vbNarrow) = "(" Or StrConv(Right(m.Value, 1), vbNarrow) = ")" Then
           Arg = Replace(Arg, m.Value, STR_BEFORE)
       End If
   Next

   VBA100本ノック_060 = Replace(Arg, STR_BEFORE, STR_AFTER)
   
   Set oRE = Nothing

End Function

別に使い慣れてもいないのですがRegExpで頭捻って書きました。
Replace関数の引数でvbTextCompare指定するの（大小・全半区別なし）紹介してましたっけ、すっかり忘れている……というかできないかググったのに見つけられなかったから探し方も良くないということに。つらい。

「㍿」はツイに記載があったものの、「㏍」「㊑」はそんな表記があるの知らなかったのですけど、「かぶしきがいしゃ」と打って変換すれば出てくるのでちゃんと探さなかったのが悪い……のか？

ChrW関数はともかくとして、解答で「ChrW(&H337F)」とかなっている引数の値をどうやって求めたらいいんだろう、というのが気になりました。ググってみると16進数。なるほど、じゃあ10進数を16進数にするには……とググったらありました。

Hex
指定された値を 16 進数で表した文字列で返します。

VBScript関数リファレンスだけど、Excelの関数にあったりしないかなーと適当なセルに「=hex」と入力してみると色々候補が……そしてやっぱりありました！

DEC2HEX 関数
10 進数を 16 進数に変換します。

というわけでちゃんと自力で対象の文字列のコード値を確認することができました！

画像1

これはちょっと嬉しい。

■60本目を終えて。

難易度が増すごとに自己肯定感が下がっていく恐ろしい100本ノック。（※ごくごく個人の感想です）
無論大変勉強にはなるのですが、問題を通して自分に内在する「ExcelVBAでプログラミングしていく上での課題」を掘り起こされることでもあり、「なるほどー！こんなやり方があるんだー！」という前向きな気持ちの隙間からその暗雲たる思いが覗いてきてつらい。
でも最後までやり切りたいなという気持ちはずっとあるので、しんどかろうがもう少し頑張ります。

あと40本！