VBA100本ノックチャレンジ:31~40本目

7割くらい使ったことがないものなのでマクロ記録とGoogle先生だよりです。

31本目。

Public Sub VBA100本ノック_031()
  
   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Dim buf As String
   Dim w As Worksheet
   For Each w In ThisWorkbook.Worksheets
       buf = buf & "," & w.Name
   Next
   buf = Right(buf, Len(buf) - 1)

   With ws.Range("A1")
       .NumberFormatLocal = "@"
       With .Validation
           .Delete
           .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=buf
           .IgnoreBlank = True
           .InCellDropdown = True
           .ErrorTitle = "入力エラー"
           .ErrorMessage = "プルダウンから選択してください。"
       End With
   End With
   
End Sub

入力規則自体はよく使うものの、VBAで設定することはあまりないのでマクロ記録から抽出。

数値のシート名012等で頭の0が消えないように表示形式を文字列に変更しています。

自分で記述した際はすっかり失念していました。確かにそうだと記述を追加。
あと、解答ではJOIN関数を使っており、平時自分では使ったことがないのでこの際に勉強。そういえばPowerShellに触れたときに配列を指定語区切りで文字列にするやつを使ったんでした。これもJOIN。

>>配列について知りたかったことのすべて
join
これは、配列内のすべての要素を、指定した文字または文字列と結合します。
PS> $data = @(1,2,3,4)
PS> $data -join '-'
1-2-3-4
PS> $data -join ','
1,2,3,4

32本目。

Public DoQuit032 As Boolean

Public Sub VBA100本ノック_032()
   
   Dim sLogFile As String
   sLogFile = "log_" & Format(Now, "yyyymmddhhmmss") & ".txt"
   sLogFile = ThisWorkbook.Path & "\" & sLogFile
   
   Dim numLogFile As Long
   numLogFile = FreeFile
   
   Open sLogFile For Output As #numLogFile
   
   Dim wb As Workbook
   For Each wb In Workbooks
       If wb.Name <> ThisWorkbook.Name Then
           Print #numLogFile, wb.FullName
           wb.Save
           wb.Close
       End If
   Next
   
   Print #numLogFile, ThisWorkbook.FullName
   Close #numLogFile
   
   DoQuit032 = True
   ThisWorkbook.Save
   
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
​
    If DoQuit032 Then
        Application.Quit
    End If
​
End Sub

ご覧の通り、めちゃくちゃ回りくどいことをしてしまいました。自ブックを終了する際にアプリケーションも終了するにはどうすればいいか?
と考えた結果、Thisworkbookモジュールにセーブ時にアプリケーションを終了する処理を入れて、ただそのままだと保存するたびに閉じてしまうので、Public変数でTrueを明示したときだけにすればいいのでは!と。
解答にあるように、全部保存してから普通にアプリケーション閉じればよかったんですね…。

Public Sub VBA100本ノック_032ans()

   Dim sLogFile As String
   sLogFile = "log_" & Format(Now, "yyyymmddhhmmss") & ".txt"
   sLogFile = ThisWorkbook.Path & "\" & sLogFile
   
   Dim numLogFile As Long
   numLogFile = FreeFile
   
   Open sLogFile For Output As #numLogFile
   
   Dim wb As Workbook
   For Each wb In Workbooks
       Print #numLogFile, wb.FullName
       wb.Save
   Next
   
   Close #numLogFile
   Application.Quit
       
End Sub

すっごくシンプル。

33本目。

Public Sub VBA100本ノック_033()

   Dim wsData As Worksheet
   Set wsData = ThisWorkbook.Worksheets("データ")
   
   Dim rowEnd As Long
   Dim rngData As Range
   With wsData
       rowEnd = .Cells(.Rows.Count, "B").End(xlUp).Row
       Set rngData = .Range(.Cells(2, "B"), .Cells(rowEnd, "F"))
   End With
   Dim arData As Variant
   arData = rngData.Value
   
   Dim wsMasta As Worksheet
   Set wsMasta = ThisWorkbook.Worksheets("マスタ")
       
   Dim rngMasta As Range
   Set rngMasta = wsMasta.Range("A1").CurrentRegion
   
   Dim myCode As String
   Dim myCount As Long
   Dim rw As Long
   For rw = 1 To UBound(arData, 1)
       myCode = arData(rw, 1)
       myCount = arData(rw, 2)
       arData(rw, 3) = WorksheetFunction.VLookup(myCode, rngMasta, 2, 0)
       arData(rw, 4) = WorksheetFunction.VLookup(myCode, rngMasta, 3, 0)
       arData(rw, 5) = myCount * arData(rw, 4)
   Next
   
   rngData.Value = arData
   
End Sub

マクロ記録から何をしたいのか読み取る問題かと思ったら(それもあるとは思いますが)さらに目線が高いというか、このケースにおける「依頼者」のレベルを想定して対応する感じの解答でした。
そういうことに全然思い至っていなかったので、ほぼまるっと書き換え。確かに動きはするけれども、これが返ってきた「依頼者」がこの後どうするのか…ということは確かに実務では考えないといけないのかも。
周りにこういったことをシェアできる人が全然いない環境にいるので、私はかなり我が強くて他人との共有に難がありそう…とは常々思っているわけですが、改めて可視化された感じ。

34本目。

Public Function VBA100本ノック_034(myArray As Variant, Optional TurnRight As Boolean = True) As Variant

   On Error Resume Next
   Dim buf As Long
   buf = UBound(myArray, 2)
   If Err.Number > 0 Then
       MsgBox "2次元配列を指定してください。"
       Exit Function
   End If
   On Error GoTo 0
   
   Dim arRet() As Variant
   ReDim arRet(LBound(myArray, 2) To UBound(myArray, 2), LBound(myArray, 1) To UBound(myArray, 1))

   Dim rowSta As Long
   Dim rowEnd As Long
   Dim colSta As Long
   Dim colEnd As Long
   Dim rowStep As Long
   Dim colStep As Long

   If TurnRight Then
       rowSta = LBound(arRet, 1)
       rowEnd = UBound(arRet, 1)
       rowStep = 1
       colSta = UBound(arRet, 2)
       colEnd = LBound(arRet, 2)
       colStep = -1
   Else
       rowSta = UBound(arRet, 1)
       rowEnd = LBound(arRet, 1)
       rowStep = -1
       colSta = LBound(arRet, 2)
       colEnd = UBound(arRet, 2)
       colStep = 1
   End If

   Dim rw As Long
   Dim cl As Long
   Dim rwCnt As Long
   Dim clCnt As Long

   clCnt = LBound(myArray, 2)
   For rw = rowSta To rowEnd Step rowStep
       rwCnt = LBound(myArray, 1)
       For cl = colSta To colEnd Step colStep
           arRet(rw, cl) = myArray(rwCnt, clCnt)
           rwCnt = rwCnt + 1
       Next cl
       clCnt = clCnt + 1
   Next rw

   VBA100本ノック_034 = arRet
   
End Function

私はアルゴリズムが弱い。
右回転のときは行は上から下に向けて小→大だからStep+1、列は右から左に向けて大←小だからStep-1にすればいいんだな!と考え、同じように左回転も上下左右の数値が増える向きでStepの値を変えて…とやった結果が上記です。
右にせよ左にせよ元の配列と行列は逆転しているので、行カウント時には元配列の列カウントアップ、列カウント時には元配列の行カウントアップ…とあれこれ試行錯誤し、うまく再現できたので解答を拝見。

Public Function VBA100本ノック_034Ans(myArray As Variant, Optional TurnRight As Boolean = True) As Variant
   
   On Error Resume Next
   Dim buf As Long
   buf = UBound(myArray, 2)
   If Err.Number > 0 Then
       MsgBox "2次元配列を指定してください。"
       Exit Function
   End If
   On Error GoTo 0
   
   Dim rowMin As Long: rowMin = LBound(myArray, 1)
   Dim rowMax As Long: rowMax = UBound(myArray, 1)
   Dim colMin As Long: colMin = LBound(myArray, 2)
   Dim colMax As Long: colMax = UBound(myArray, 2)
   
   Dim arRet() As Variant
   ReDim arRet(colMin To colMax, rowMin To rowMax)

   Dim rw As Long
   Dim cl As Long
   For rw = rowMin To rowMax
       For cl = colMin To colMax
           If TurnRight Then
               arRet(cl, rowMax - rw + rowMin) = myArray(rw, cl)
           Else
               arRet(colMax - cl + colMin, rw) = myArray(rw, cl)
           End If
       Next cl
   Next rw

   VBA100本ノック_034Ans = arRet
   
End Function

シンプル。(一応解答を見て自分で書き直したもの)
元の配列との行列の関係性をきちんと整理すれば、すっきりしたものになるんだなあという改めての学び…。

35本目。

Public Sub VBA100本ノック_035()
   
   Dim ws As Worksheet
   Set ws = ActiveSheet

   Dim rngArea As Range
   With ws.Range("B2").CurrentRegion
       With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
           Set rngArea = Union(.Offset(0, 3), .Offset(0, 5))
       End With
   End With
   
   With rngArea
       .FormatConditions.Delete

       .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="=1.0"
       With .FormatConditions(.FormatConditions.Count)
           .Font.Color = vbRed
           .StopIfTrue = True
       End With

       .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="=0.9"
       With .FormatConditions(.FormatConditions.Count)
           .Interior.Color = vbRed
           .StopIfTrue = True
       End With
       
       .FormatConditions(2).SetFirstPriority
   End With
   
End Sub

条件付き書式、31本目の入力規則と同じくらいよく使うものの、VBAではあんまり取り扱わないです。よってマクロ記録。
記述のあと解答を見ると、おおよそ同じながら解答はすごくシンプルになっている。

Sub VBA100_35_01()
  Dim ws As Worksheet
  Set ws = ActiveSheet
  
  With ws.Range("E:E,G:G").FormatConditions
    .Delete
    With .Add(Type:=xlExpression, Formula1:="=AND(E1<>"""",E1<0.9)")
      .Interior.Color = vbRed
    End With
    With .Add(Type:=xlExpression, Formula1:="=AND(E1<>"""",E1<1)")
      .Font.Color = vbRed
    End With
  End With
End Sub

マクロ記録だとAddしたオブジェクトをそのままWithで扱う記述にはならないので、これはちゃんと書き手がこういう使い方をできると知っておかなくてはならないことなんだろうなと。自分で取り扱ったことが少ない記述でも、こういうところに気づけるかどうかで習熟度が分かれそう。
あと、この場合の2種類の条件付き書式はどちらを優先するかで表示が変わるので、「SetFirstPriority」をどう使うか、などあれこれ試行錯誤しました。難しい。

36本目。

Public Sub VBA100本ノック_036()
   
   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   With ws
       Dim colEnd As Long
       colEnd = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
       Dim colTmp As Long
       colTmp = colEnd + 2
   
       Dim i As Long
       Dim t As Long
       For i = colEnd To 1 Step -1
           For t = 1 To i - 1
               If GetNumber(.Cells(1, t).Value) > GetNumber(.Cells(1, t + 1).Value) Then
                   .Columns(t).Copy .Columns(colTmp)
                   .Columns(t + 1).Copy .Columns(t)
                   .Columns(colTmp).Copy .Columns(t + 1)
               End If
           Next t
       Next i
       
       .Columns(colTmp).Clear
   End With
   
End Sub
Private Function GetNumber(ColumnName As String) As Long

   Dim iStart As Long
   iStart = InStr(ColumnName, "(") + 1
   
   Dim iLen As Long
   iLen = InStr(ColumnName, ")") - iStart
   
   GetNumber = CLng(Mid(ColumnName, iStart, iLen))
   
End Function

アルゴリズムの復習だー!
ということで、何も見ずにバブルソートがちゃんとできるか、たいへん手こずりながらも頑張りました!
列の交換自体はふつうにColumns(n+1).Cut → Columns(n).Insertでよかったのでわざわざ使っていない列に退避させてから列を入れ替えてるこのやり方はあまりよくないと思いますが、バブルソートはちゃんとできたので自分を褒めます。

自分を褒めつつ、Val関数で数値への変換がとても簡単にできるだとか、Sortが列方向にも使えるだとか(これは聞いたことはあった)、そういうことを覚えていきたい。

37本目。

Public Sub VBA100本ノック_037()

   Dim ws As Worksheet
   Set ws = ActiveSheet

   Dim obj As FullSeriesCollection
   Set obj = ws.ChartObjects(1).Chart.FullSeriesCollection
   
   Dim ipMax As Double
   Dim ipMin As Double

   Dim p As Point
   For Each p In obj(1).Points
       If ipMax = 0 Then
           ipMax = p.Top
           ipMin = p.Top
       End If
       
       Select Case p.Top
       Case Is > ipMax: ipMax = p.Top
       Case Is < ipMin: ipMin = p.Top
       End Select
   Next
   
   For Each p In obj(1).Points
       With p
           Select Case .Top
           Case ipMax
               .Format.Fill.ForeColor.RGB = RGB(0, 255, 0)
               .ApplyDataLabels
           Case ipMin
               .Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
               .ApplyDataLabels
           Case Else
               .Format.Fill.ForeColor.RGB = RGB(95, 95, 95)
               On Error Resume Next
               .DataLabel.Delete
               On Error GoTo 0
           End Select
       End With
   Next
   
End Sub

VBAでグラフをいじったことはほぼ皆無だったので例のごとくマクロ記録を頼りましたが、そこからあえてググらずにそれらしい変数を宣言して自動メンバを見つつ組んでみました。
どうやらグラフの棒はPointというらしい、これは縦軸グラフなのでTopプロパティで縦の長さが取得できる、ならそれが一番長いものが最大、短いものが最小と分かるのでは…?ということで、このような記述になりました。
一方その頃解答では、グラフのもととなるセル範囲との関係をちゃんと承知したうえでスマートな内容を書いていた…。

38本目。

Public Sub VBA100本ノック_038()
   
   Dim dicHoliday As Object
   Set dicHoliday = CreateObject("Scripting.Dictionary")
   
   Dim myDate As Date
   Dim rw As Long
   With ThisWorkbook.Worksheets("祝日")
       For rw = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
           myDate = .Cells(rw, 1).Value
           If Not dicHoliday.Exists(myDate) Then
               dicHoliday.Add myDate, ""
           End If
       Next
   End With
   
   Dim wsData As Worksheet
   Set wsData = ThisWorkbook.Worksheets("売上")
   With wsData
       For myDate = WorksheetFunction.Min(.Columns(1)) To WorksheetFunction.Max(.Columns(1))
           Select Case Weekday(myDate)
           Case 1, 7
               If Not dicHoliday.Exists(myDate) Then
                   dicHoliday.Add myDate, ""
               End If
           End Select
       Next
   End With

   Dim wsHoliday As Worksheet
   Set wsHoliday = ThisWorkbook.Worksheets("土日祝")
   wsHoliday.Range("A1").CurrentRegion.Offset(1, 0).ClearContents

   Dim wsWorkday As Worksheet
   Set wsWorkday = ThisWorkbook.Worksheets("平日")
   wsWorkday.Range("A1").CurrentRegion.Offset(1, 0).ClearContents

   Dim wsTarget As Worksheet
   With wsData
       For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
           myDate = .Cells(rw, 1).Value
           If dicHoliday.Exists(myDate) Then
               Set wsTarget = wsHoliday
           Else
               Set wsTarget = wsWorkday
           End If
           
           .Rows(rw).Copy wsTarget.Rows(wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Offset(1, 0).Row)
           Application.CutCopyMode = False
       Next
   End With
   
End Sub

割と使う処理なのですが、うまく扱えているとは限らない好例。
細かいところ、たとえばWeekday関数では引数に開始曜日を与えることでインデックスをずらせるので、月曜始まりにすれば土日は「6と7」=「6以上」になる…みたいなところを失念しているだとか、DictionaryはExistsで速くチェックができると言っても今回のようにそれ以外の条件があるときは素直にキー列を追加してオートフィルタした方が楽だとか、「分かっている/分かっていたのに使いこなせていない」のが逆に如実になってしまってちょっと凹む。特にオートフィルタは割と好きなのに…。
別解のUnionを使うものも、どこかの回で自分で使っているのにここに適用できていないので、やっぱり自分はまだうまく使えてないんだなーってしょんぼりするやつですね。うーん、どうすればうまく使えるようになるのか…。

39本目。

Public Sub VBA100本ノック_039()
   
   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   With ws
       Dim rngArea As Range
       Set rngArea = .Range("A1").CurrentRegion.Resize(, 2)
       
       Dim ary() As Variant
       ReDim ary(WorksheetFunction.Max(rngArea))
   
       Dim r As Range
       For Each r In rngArea
           ary(r.Value) = r.Value
       Next
       
       .Columns(3).ClearContents
       
       Dim elm As Variant
       For Each elm In ary
           If elm <> "" Then
               With .Cells(.Rows.Count, 3).End(xlUp)
                   If .Value = "" Then
                       .Value = elm
                   Else
                       .Offset(1, 0).Value = elm
                   End If
               End With
           End If
       Next
   End With
   
End Sub

「ああ、これは36本目で例に出していたバケットソートを使うんだな」と思って書いて解答見たら全然違った。いやこれでも同じ結果にはなるんですが。
解答の方は、A列とB列を比較して、どちらかより小さいあるいは同値ならC列に値を記述して行カウントアップ、ということで、私の記述ではセル内の数値に制限がありますがこちらは大きい数値でも比較ができて汎用性が高い…。

40本目。

Public Sub VBA100本ノック_040()
   
   Dim sFolderPath As String
   sFolderPath = ThisWorkbook.Path & "\data"
   If Dir(sFolderPath, vbDirectory) = "" Then
       MsgBox sFolderPath & "が見つかりません。"
       Exit Sub
   End If
   
   Dim wsPaste As Worksheet
   Set wsPaste = ThisWorkbook.Worksheets("2020年12月")
   wsPaste.Cells.ClearContents
   
   Dim sName As String
   sName = Dir(sFolderPath & "\*.xls*")
   
   Do Until sName = ""
       Dim sPath As String
       sPath = sFolderPath & "\" & sName
               
       Dim wb As Workbook
       On Error Resume Next
       Set wb = Workbooks(sName)
       If Err.Number > 0 Then
           Set wb = Workbooks.Open(sPath)
       End If
       On Error GoTo 0
       
       Dim ws As Worksheet
       On Error Resume Next
       Set ws = wb.Worksheets(wsPaste.Name)
       If Err.Number = 0 Then
           If wsPaste.Range("A1").Value = "" Then
               ws.Cells.Copy wsPaste.Cells
           Else
               ws.Range("A1").CurrentRegion.Offset(1, 0).Copy
               wsPaste.Cells(wsPaste.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
           End If
           Application.CutCopyMode = False
       End If
       On Error GoTo 0
       
       wb.Close False
       sName = Dir()
   Loop
   
End Sub

これだけはもう実務でめちゃくちゃ使う記述なので、今までで一番すんなり書けました。やはり経験なのか。Dir関数便利なんですが、ループ中にうっかり別のところで使ってしまうとDir()の内容が変わってしまい、それ原因でのエラーで苦戦した記憶があります。

■40本目を終えて

まだ折り返しですらないのに泣き言が増えていますね。そんな方法があったのか!と素直に感嘆できるものもあれば、ああああ分かってたのに使えなかった…と悔しくなるものもあり、でも先に述べたようにこういったことは一人でもくもくやってもくもくセルフ駄目だしして合っているのかも分からないままもくもくと書き直して……が当たり前だったので、やっぱり楽しいと思います。良い機会。

ところでこの記事の冒頭、リンクを貼りたかったのになぜかコードになってしまっていて、文字は消したものの、コード枠自体を消そうとしても消せませんでした。すみません。