VBA100本ノックチャレンジ：41～50本目

Yuzunoki

久々に着手。ようやく折り返しですけど正直めっちゃしんどい！！

41本目。

Public Sub VBA100本ノック_041()

   Dim cntCorrected As Long
   Dim i As Long
   For i = 1 To 10
       Dim intL As Long
       Dim intR As Long
       Dim Operator As String
       Dim Result As Long
       Select Case getRandomInteger(3)
       Case 0
           intL = getRandomInteger(100, 1)
           intR = getRandomInteger(100, 1)
           Operator = "＋"
           Result = intL + intR
       Case 1
           intL = getRandomInteger(100, 10)
           intR = getRandomInteger(intL - 1, 1)
           Operator = "－"
           Result = intL - intR
       Case 2
           intL = getRandomInteger(100, 1)
           intR = getRandomInteger(10, 2)
           Operator = "×"
           Result = intL * intR
       Case 3
           intR = getRandomInteger(10, 2)
           intL = intR * getRandomInteger(10, 2)
           Operator = "÷"
           Result = intL / intR
       End Select
       
       Dim Answer As Variant
       Answer = Val(InputBox("第" & i & "問目" & vbCrLf & vbCrLf & intL & Operator & intR))
       If Result = Answer Then cntCorrected = cntCorrected + 1
   Next
   
   Dim Message As String
   Message = "発表！" & vbCrLf & vbCrLf & "正解数：" & cntCorrected & vbCrLf & vbCrLf
   
   Select Case cntCorrected
   Case 0: Message = Message & "計算をもっとがんばろう！"
   Case 1 To 3: Message = Message & "もう少しがんばってみよう！"
   Case 4 To 6: Message = Message & "いい感じ！まだまだがんばろう！"
   Case 7 To 9: Message = Message & "惜しい！あとちょっと！"
   Case 10: Message = Message & "よくできました！"
   End Select
   
   MsgBox Message
   
End Sub
Private Function getRandomInteger(intMax As Long, Optional intMin As Long = 0) As Long

   getRandomInteger = Int(Rnd() * (intMax - intMin + 1)) + intMin

End Function

長い！ごくシンプルに「Evaluate」を知りませんでした。あるといいのになあと思っていたらあるんですねこういうの。
あとRnd()は知ってたんですけど、「Randomizeステートメント」も知らなかったです。

・Evaluateメソッド（文字列の数式を実行します）
・Randomizeステートメント

42本目。

Public Sub VBA100本ノック_042()

   Dim wsKaiso As Worksheet
   Set wsKaiso = ThisWorkbook.Worksheets("階層")
   
   Dim arKaiso As Variant
   arKaiso = wsKaiso.Range("A1").CurrentRegion.Value

   Dim arKaisoDB() As Variant
   ReDim arKaisoDB(LBound(arKaiso, 1) To UBound(arKaiso, 1), LBound(arKaiso, 2) To UBound(arKaiso, 2))
   Dim cnt As Long
   
   Dim rw As Long
   Dim cl As Long
   For rw = 2 To UBound(arKaiso, 1)
       For cl = 1 To 3
           If arKaiso(rw, cl) = "" Then
               arKaiso(rw, cl) = arKaiso(rw - 1, cl)
           End If
       Next
       If arKaiso(rw, 4) <> "" Then
           cnt = cnt + 1
           For cl = 1 To UBound(arKaisoDB, 2)
               arKaisoDB(cnt, cl) = arKaiso(rw, cl)
           Next
       End If
   Next
   
   Dim wsKaisoDB As Worksheet
   Set wsKaisoDB = ThisWorkbook.Worksheets("階層DB")
   
   With wsKaisoDB
       .Cells.ClearContents
       wsKaiso.Rows(1).Copy .Rows(1)
       Application.CutCopyMode = False
       
       .Range("A2").Resize(UBound(arKaisoDB, 1), UBound(arKaisoDB, 2)).Value = arKaisoDB
   End With
   
End Sub

これは完全に手癖。何かというと配列で済まそうとしちゃうから、やっぱり長くなっちゃいますね。
こればっかりは駄目だと思って、以前「空白セルを選択して一個上のセル参照すればいいよ」というのを思い出して別解も記載。

Public Sub VBA100本ノック_042_Other()

   Dim wsKaiso As Worksheet
   Set wsKaiso = ThisWorkbook.Worksheets("階層")

   Dim wsKaisoDB As Worksheet
   Set wsKaisoDB = ThisWorkbook.Worksheets("階層DB")
   wsKaisoDB.Cells.ClearContents

   Dim rngBlank As Range
   Set rngBlank = wsKaiso.Range("A1").CurrentRegion.Resize(, 3)
   Set rngBlank = rngBlank.SpecialCells(xlCellTypeBlanks)
   rngBlank.Formula2R1C1 = "=R[-1]C"

   wsKaiso.Range("A1").AutoFilter 4, "<>"
   wsKaiso.Range("A1").CurrentRegion.Copy wsKaisoDB.Range("A1")
   Application.CutCopyMode = False
   
   wsKaiso.AutoFilterMode = False
   rngBlank.ClearContents
   
End Sub

なお正式な回答はさらにシンプルで、こういうのが考えつかないんだよなーと悔しい思いをします。厄介なタイプの負けず嫌い……。

43本目。

Public Sub VBA100本ノック_043()

   Dim ws As Worksheet
   Set ws = ThisWorkbook.Worksheets("CSV")
   With ws
       .Columns(1).NumberFormatLocal = "yyyy-mm-dd"
       .Columns(2).NumberFormatLocal = "0"
       .Columns(3).NumberFormatLocal = "0.00"
       .Columns(4).NumberFormatLocal = "@"
   End With
   
   Dim sBase As String
   sBase = ThisWorkbook.FullName
   sBase = Left(sBase, InStrRev(sBase, ".") - 1)
   
   Dim cnt As Long
   Dim sPath As String
   Do Until Dir(sPath) = ""
       sPath = sBase & IIf(cnt = 0, "", "(" & cnt & ")") & ".csv"
       cnt = cnt + 1
   Loop
       
   ws.Copy
   ActiveWorkbook.SaveAs Filename:=sPath, FileFormat:=xlCSV, Local:=True
   ActiveWorkbook.Close
   
End Sub

実務ではあんまりCSV化しないので、マクロ記録から。前回覚えたIIFを使いたくてちょくちょく挟んでいます。便利で好き。

44本目。

Public Sub VBA100本ノック_044()
   
   Dim wsResult As Worksheet
   Set wsResult = ThisWorkbook.Worksheets("044")
   With wsResult
       .Cells.ClearContents
       .Range("A1").Value = "テーブル名"
       .Range("B1").Value = "シート名"
       .Range("C1").Value = "セル範囲"
       .Range("D1").Value = "リスト行数"
       .Range("E1").Value = "リスト列数"
   End With
   
   Dim ws As Worksheet
   For Each ws In ThisWorkbook.Worksheets
       If ws.Name <> wsResult.Name Then
           Dim oList As ListObject
           For Each oList In ws.ListObjects
               With wsResult
                   With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                       .Offset(0, 0).Value = oList.Name
                       .Offset(0, 1).Value = oList.Parent.Name
                       .Offset(0, 2).Value = oList.Range.Address
                       .Offset(0, 3).Value = oList.ListRows.Count
                       .Offset(0, 4).Value = oList.ListColumns.Count
                   End With
               End With
           Next
       End If
   Next
   
End Sub

テーブル使ったことありません！由々しき事態。VBA以前にテーブルの使い方を覚えるべき…。
これも使ったことがなかったので、マクロ記録で「どうやら【ListObject】で管理されてるらしい」と判断、変数で宣言して自動メンバからいろいろプロパティを選び、Debug.Printしてみて何のプロパティか確認したりしました。ググった方が勿論早いけど。

本筋には関係ないんですけど、今まで1行目に項目名反映するときは上のコードみたいに書いてたんですが、

Range("A1:C1").Value = Array("ID", "氏名", "年齢")

みたいに書いても同じって、配列を値に代入するのよくやってるくせに今まで全然気づかなくて「ウワッ！！！」てなりました。こういうところがシンプル化ポイント……！

45本目。

Public Sub VBA100本ノック_045()
   
   Dim ws As Worksheet
   Set ws = ThisWorkbook.Worksheets("045")
   
   Dim oList As ListObject
   Set oList = ws.ListObjects(1)
   
   With oList
       On Error Resume Next
       .ListColumns("合計列1").Delete
       .ListColumns("合計列2").Delete
       On Error GoTo 0
       
       .ListColumns.Add(6).Range(1) = "合計列2"
       .ListColumns.Add(4).Range(1) = "合計列1"
       
       .ListColumns(4).Range(2) = "=SUM([@列1]:[@列3])"
       .ListColumns(7).Range(2) = "=SUM([@列4]:[@列5])"
   End With
   
End Sub

普通にググりました。ほぼコピペ。

列を追加/削除する

そして公式回答がものすごくすっきり……ちょっと凹んじゃうくらい……綺麗に分かりやすくコード書くのって本当に難しい。

46本目。

Public Sub VBA100本ノック_046()

   Dim ws As Worksheet
   Set ws = ThisWorkbook.Worksheets("名前定義")
   
   Dim rngArea As Range
   Set rngArea = ws.Range("A1").CurrentRegion
   
   Dim myName As String
   Dim r As Range
   For Each r In rngArea
       If Len(r.Value) = 0 Then GoTo Next_Handle
       If LenB(r.Value) > 255 Then
           Call ps_DebugPrint046(r.Value, "定義できるのは半角で数えて255文字まで")
           GoTo Next_Handle
       End If
       
       If StrConv(r.Value, vbNarrow + vbLowerCase) Like "[cr]" Then
           Call ps_DebugPrint046(r.Value, "r,R,c,Cいずれか1文字のみの場合は使用できない")
           GoTo Next_Handle
       End If

       Dim i As Long
       myName = ""
       For i = 1 To Len(r.Value)
           Dim buf As String
           buf = myName & Mid(r.Value, i, 1)
           buf = Replace(buf, " ", "_")
           buf = Replace(buf, "　", "_")
           If buf = "." Or IsNumeric(buf) Then buf = "_" & buf

           On Error Resume Next
           If ps_ExistsName(buf) Then
               myName = buf
           Else
               ThisWorkbook.Names.Add buf, ws.Name & "!" & r.Address
               myName = IIf(Err.Number > 0, myName & "_", buf)
               ThisWorkbook.Names(buf).Delete
           End If
           On Error GoTo 0
       Next
       
       If ps_ExistsName(myName) Then
           Call ps_DebugPrint046(myName, "すでに同名が定義されている")
           GoTo Next_Handle
       End If
       
       On Error Resume Next
       ThisWorkbook.Names.Add myName, ws.Name & "!" & r.Address
       If Err.Number > 0 Then
           Call ps_DebugPrint046(myName, "（元：" & r.Value & "）" & "/" & Err.Description)
       End If
       On Error GoTo 0
       
Next_Handle:
   Next
   
End Sub
Private Sub ps_DebugPrint046(sName As String, Description As String)

   Debug.Print sName; ":"; Description

End Sub
Private Function ps_ExistsName(sName As String) As Boolean

   ps_ExistsName = False

   Dim n As Name
   For Each n In ThisWorkbook.Names
       If UCase(n.Name) = UCase(sName) Then
           ps_ExistsName = True
           Exit Function
       End If
   Next

End Function

これ本当に頭抱えました。使える文字・使えない文字はググったんですけど……。

Excel2010-2016：名前に使える文字・使えない文字

どう再現したらいいのか途方に暮れて、結局「1文字ずつ実際に名前登録してみて、エラーが起こったらアンダーバーにする」みたいなやり方になりました。
まあ公式回答がものすごくすっきりして読みやすいのはいつものこととして、その中で知らなかったことが2点。

WorksheetFunction.Clean メソッド (Excel)

使ったことなくて知りませんでした。Worksheet関数なんで、そういえばExcelシート上で関数ベタ打ちしてるときに「CLEAN」というのは見たことがあったけど。

あと、Mid関数でそのまま代入すればその文字だけ入れ替わるのも知りませんでした。へー！！めっちゃ便利！！

Sub TestMid()
   Dim buf: buf = "123456789"

   Dim i
   For i = 1 To Len(buf)
       If Mid(buf, i, 1) Mod 3 = 0 Then
           Mid(buf, i, 1) = "a"
       End If
   Next

   Debug.Print buf ' -> 12a45a78a
End Sub

47本目。

Public Sub VBA100本ノック_047()

   ThisWorkbook.Activate
   
   Dim ws As Worksheet
   For Each ws In ThisWorkbook.Worksheets
   
       With ws
           .Activate
           .Range("A1").Select
           .PageSetup.Orientation = xlLandscape
       End With
       
       With ActiveWindow
           .Zoom = 85
           .DisplayGridlines = False
           .View = xlNormalView
       End With
       
   Next
   
End Sub

これもマクロ記録から。でも実行しててちょっと重ためだと思っていたら、「Application.PrintCommunication」でプリンター設定の同期を一時停止させられるんですね。なるほど……。
あと「Application.Goto」、VBA勉強であれこれ見てる時に見かけた記憶はあったんですがすっかり忘れてました。スクロールはされるが非表示はそのまま……普通にSelectしか選択肢がないとハマっちゃう場面があるのか。

・Application.PrintCommunication
・Application.Goto

48本目。

Public Function VBA100本ノック_048(v As Variant) As Variant

   If Not IsArray(v) Then GoTo End_Handle

   Dim tmp As Variant
   Dim dimension As Long
   On Error Resume Next
   tmp = UBound(v, 3)
   If Err.Number = 0 Then GoTo End_Handle
   Err.Clear

   tmp = UBound(v, 2)
   dimension = IIf(Err.Number = 0, 2, 1)
   On Error GoTo 0

   Dim rw As Long, cl As Long
   Dim buf As Variant
   Select Case dimension
       Case 1
           For rw = LBound(v) To UBound(v)
               If VarType(v(rw)) = vbSingle Or VarType(v(rw)) = vbDouble Then
                   v(rw) = WorksheetFunction.RoundDown(v(rw), 0)
               End If
           Next

       Case 2
           For rw = LBound(v, 1) To UBound(v, 1)
               For cl = LBound(v, 2) To UBound(v, 2)
                   If VarType(v(rw, cl)) = vbSingle Or VarType(v(rw, cl)) = vbDouble Then
                       v(rw, cl) = WorksheetFunction.RoundDown(v(rw, cl), 0)
                   End If
               Next
           Next

   End Select

End_Handle:
   VBA100本ノック_048 = v

End Function

あんまりよくない。あと、Function指定だったからか、なぜか「なるべく1つのプロシージャに収めた方がいいか？」みたいな発想になってしまって、公式回答見たときに「分かったはずなのに分からなかった……」みたいな凹み方をしました。何次元かなんて外に出しちゃってもよかったんですよね。

Private Function pf_GetCountDimension(v As Variant) As Long

   Dim cnt As Long

   If Not IsArray(v) Then GoTo End_Handle
   On Error GoTo End_Handle
   Do Until Err.Number <> 0
       If IsNumeric(UBound(v, cnt + 1)) Then
           cnt = cnt + 1
       End If
   Loop
   
End_Handle:
   pf_GetCountDimension = cnt

End Function

この問題は他にも反省点多くて、VarTypeを思い出せたのは良かったものの、ここもなぜか「Select Case使わない方がいいのかな…」とか思いこんじゃってIFで記述したため、結局CurrencyとかDecimalを見逃してます。

あと知らなかったFix関数。RoundDown使っちゃいましたが、半端に知ってるせいで他のやり方を知らないままっていうのは良くないですね……。

Fix

49本目。

Public Sub VBA100本ノック_049()
   
   Dim wsIn As Worksheet
   Set wsIn = ThisWorkbook.Worksheets("49In")
   
   Dim wsOut As Worksheet
   Set wsOut = ThisWorkbook.Worksheets("49Out")
   wsOut.Cells.Clear
   wsIn.Rows(1).Copy wsOut.Rows(1)
   Application.CutCopyMode = False

   Call ps_CopyPaste(wsIn, RGB(255, 0, 0), xlFilterCellColor, wsOut)
   Call ps_CopyPaste(wsIn, RGB(255, 255, 0), xlFilterCellColor, wsOut)
   Call ps_CopyPaste(wsIn, RGB(255, 0, 0), xlFilterFontColor, wsOut)
  
End Sub
Private Sub ps_CopyPaste(wsSrc As Worksheet, myColor As Long, myOperator As XlAutoFilterOperator, wsDst As Worksheet)

   With wsSrc
       .AutoFilterMode = False
       .Range("A1").AutoFilter Field:=4, Criteria1:=myColor, Operator:=myOperator
       
       Dim rngCopy As Range
       Set rngCopy = .Range("A1").CurrentRegion.Offset(1, 0)
   End With

   With wsDst
       Dim rowTarget As Long
       rowTarget = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   
       rngCopy.Copy .Cells(rowTarget, 1)
       Application.CutCopyMode = False
       
       With .Range(.Cells(rowTarget, 4), .Cells(.Rows.Count, 4).End(xlUp))
           Select Case myOperator
               Case xlFilterCellColor: .Interior.Color = myColor
               Case xlFilterFontColor: .Font.Color = myColor
           End Select
       End With
   End With
   
   wsSrc.AutoFilterMode = False

End Sub

同じことの繰り返しなので、何とか関数にできないかなあと試行錯誤したやつ。せっかくなので、これは別案も記述しました。

Public Sub VBA100本ノック_049_Other()
   
   Dim wsIn As Worksheet
   Set wsIn = ThisWorkbook.Worksheets("49In")
   
   Dim wsOut As Worksheet
   Set wsOut = ThisWorkbook.Worksheets("49Out")
   wsOut.Cells.Clear
   Call ps_CopyPaste_Other(wsIn.Rows(1), wsOut.Rows(1))

   With wsIn
       Dim myInteriorColor As Long
       Dim myFontColor As Long
       Dim myRow As Long
       Dim rw As Long
       For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
           myRow = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
           
           myInteriorColor = .Cells(rw, 4).DisplayFormat.Interior.ColorIndex
           Select Case myInteriorColor
               Case 3, 6
                   Call ps_CopyPaste_Other(.Rows(rw), wsOut.Rows(myRow))
                   wsOut.Cells(myRow, 4).Interior.ColorIndex = myInteriorColor
           End Select
           
           myFontColor = .Cells(rw, 4).DisplayFormat.Font.ColorIndex
           Select Case .Cells(rw, 4).DisplayFormat.Font.ColorIndex
               Case 3
                   Call ps_CopyPaste_Other(.Rows(rw), wsOut.Rows(myRow))
                   wsOut.Cells(myRow, 4).Font.ColorIndex = myFontColor
           End Select
       Next
   End With
  
End Sub
Private Sub ps_CopyPaste_Other(src As Range, dst As Range)

   src.Copy dst
   Application.CutCopyMode = False

End Sub

公式回答は、あえてどちらかと言えば別解寄り（一行ずつDisplayFormatでチェックして反映）。
もちろん「DisplayFormat」とか知らなかったので、これもググった奴です。

【VBA】条件付き書式の色を取得【DisplayFormatを使う】

50本目。

Public Sub VBA100本ノック_050()

   Dim arSequence As Variant
   arSequence = Array(0, 0, 1)
   
   On Error Resume Next
   Do Until Err.Number <> 0
       ps_tribonacci_series ary:=arSequence
   Loop
   On Error GoTo 0
   
   Dim ws As Worksheet
   Set ws = ActiveSheet
   ws.Cells.ClearContents
   
   Dim rw As Long
   Dim elm As Variant
   For Each elm In arSequence
       rw = rw + 1
       ws.Cells(rw, 1).Value = "'" & elm
   Next

End Sub
Private Sub ps_tribonacci_series(ByRef ary As Variant)

   Dim iMax As Long: iMax = UBound(ary)
   ReDim Preserve ary(iMax + 1)
   ary(iMax + 1) = WorksheetFunction.Sum(ary(iMax - 2), ary(iMax - 1), ary(iMax))

End Sub

トリボナッチ数列って何！？（ちゃんと説明されてます）
32bit版なので知らなかったんですが、64bitならlonglongなんてあるんですね。
ps_tribonacci_seriesで、最初は変数long型で宣言して足してたら割とすぐ止まっちゃったんで、Sum関数使ったらどうかな？と試してみたら1000行超えたのでいけるのでは！？となったんですけど、解答見るとLongLong型でも100行程度だったので、数値として認識できないのであればこれはやっぱり誤りってことでしょうか……。

■50本目を終えて。

普通に難しいし、これでまだ折り返しだし！
問題を提供くださっているエクセルの神髄さんは、リプライなりくれたらどんなコードでも見ますということをおっしゃってくださってますが、これ投げても……うーん……。

でも取り組んでいて思うのが、私はやっぱり独りよがりなコードしか書けてないなってことなので、ガツンと言ってもらった方がいいのかなとも思います。

まだもうちょっと頑張ります。