VBA100本ノックチャレンジ：21～30本目

Yuzunoki

独学なりに何回か作ったことのある構成と、ない構成での差が大きくなってきました。

21本目。

Public Sub VBA100本ノック_021()

   Dim sBackupFolder As String
   sBackupFolder = ThisWorkbook.Path & "\BACKUP"
   If Dir(sBackupFolder, vbDirectory) = "" Then
       MkDir sBackupFolder
   End If
   
   Dim oFSO As Object
   Set oFSO = CreateObject("Scripting.FileSystemObject")

   Dim sBaseName As String
   sBaseName = oFSO.GetBaseName(ThisWorkbook.Name)
   
   Dim sExtensionName As String
   sExtensionName = oFSO.GetExtensionName(ThisWorkbook.Name)
   
   Dim oRE As Object
   Set oRE = CreateObject("VBScript.RegExp")
   oRE.Pattern = "^" & sBaseName & "_+|\." & sExtensionName & "$"
   oRE.Global = True
   
   Dim sName As String
   Dim varDate As Variant
   
   sName = Dir(sBackupFolder & "\" & sBaseName & "_*." & sExtensionName)
   Do Until sName = ""
       varDate = oRE.Replace(sName, "")
       varDate = Left(varDate, 4) & "年" & Mid(varDate, 5, 2) & "月" & Mid(varDate, 7, 2) & "日"
       If IsDate(varDate) Then
           If DateDiff("y", CDate(varDate), Date) > 30 Then
               oFSO.DeleteFile oFSO.BuildPath(sBackupFolder, sName)
           End If
       End If
       
       sName = Dir()
   Loop
   
End Sub

前回（16本目）で正規表現（RegExp）のやり方が自力で発想できなかったので、今回ちょっと無理目ながら使用してみた。文頭と文尾をoRE.Replaceで消してしまえば、取得したいyyyymmddhhmmの部分が取り出せる寸法。
しかし何回やっても文頭しか消せず、何でかと思ってふと「oRE.Global = true」を宣言してみたら正解。身になりました。
（Globalプロパティ：検索対象の文字列内で、文字列全体を検索するにはTrueを設定する※デフォルトではFalse）

22本目。

Public Sub VBA100本ノック_022()

   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Const conFizz = "Fizz"
   Const conBuzz = "Buzz"
   
   Dim rw As Long
   For rw = 1 To 100
       
       Select Case True
       Case rw Mod (3 * 5) = 0
           ws.Cells(rw, 4).Value = conFizz & conBuzz
       
       Case rw Mod 5 = 0
           ws.Cells(rw, 3).Value = conBuzz
       
       Case rw Mod 3 = 0
           ws.Cells(rw, 2).Value = conFizz
       
       Case Else
           ws.Cells(rw, 1).Value = rw
       
       End Select
       
   Next
   
End Sub

わあい遊ぶの大好き！
それはともかく、特筆することもないSelectCaseを使ったコードにしました。
他の方の回答で「IIf」を使っているものがあり、前回（20本目）で目にして存在を知ったつもりではいたけれども、自分の発想の中に組み込むのはそうたやすいことではないのだなと再確認。

23本目。

Public Sub VBA100本ノック_023()

   Dim wb1 As Workbook
   Set wb1 = getWorkbook(ThisWorkbook.Path & "\Book_20201101.xlsx")
   If wb1 Is Nothing Then
       MsgBox "ファイル：Book_20201101.xlsxが見つかりません。"
       Exit Sub
   End If

   Dim wb2 As Workbook
   Set wb2 = getWorkbook(ThisWorkbook.Path & "\Book_20201102.xlsx")
   If wb2 Is Nothing Then
       MsgBox "ファイル：Book_20201102.xlsxが見つかりません。"
       Exit Sub
   End If
   
   Dim dic As Object
   Set dic = CreateObject("Scripting.Dictionary")
   
   Dim ws As Worksheet
   For Each ws In wb1.Worksheets
       dic.Add ws.Name, "不一致"
   Next
   For Each ws In wb2.Worksheets
       If Not dic.Exists(ws.Name) Then
           dic.Add ws.Name, "不一致"
       Else
           dic.Item(ws.Name) = "一致"
       End If
   Next
   
   Dim buf As String
   Dim key As Variant
   For Each key In dic.Keys
       buf = buf & vbCrLf & key & "：" & dic.Item(key)
   Next
   
   MsgBox wb1.Name & "と" & wb2.Name & "のシート構成：" & buf

End Sub
Private Function getWorkbook(sPath As String) As Workbook
   
   Dim wb As Workbook
   For Each wb In Workbooks
       If wb.Name = Dir(sPath) Then
           Set getWorkbook = wb
           Exit Function
       End If
   Next
   
   If Dir(sPath) <> "" Then
       Set getWorkbook = Workbooks.Open(sPath)
   End If
   
End Function

Dictionaryを使用。業務上取り扱うデータの関係で、個人的には割とよく使っているつもりです。やっぱりユニーク化できるのがとっても便利。
あと今回は外部Excelファイルが2つだったので、Excelを開く処理をFunction化。これもよく使う。

24本目。

Public Function VBA100本ノック_024(sWord As String) As String

   Dim oRE As Object
   Set oRE = CreateObject("VBScript.RegExp")
   
   oRE.Pattern = "[ａ-ｚa-z０-９]"
   oRE.Global = True
   oRE.IgnoreCase = True
   
   Dim ret As String
   Dim buf As String
   
   If Len(sWord) > 0 Then
       Dim i As Long
       For i = 1 To Len(sWord)
           buf = Mid(sWord, i, 1)
           If oRE.Test(buf) Then
               buf = StrConv(buf, vbUpperCase + vbNarrow)
           End If
           ret = ret & buf
       Next
   End If

   VBA100本ノック_024 = ret
   
End Function

正規表現やっぱり難しい。
回答にSelectCaseを使ったものがあって、Case n To nで間を指定できるのは知っていたけど、使っていたのは数値だけだったので、Case ”a” To "z"とかが有効なのは初めて知りました。意外と便利！
その分、VBSではCase ToもLikeも使えない惜しさが際立つ。

25本目。

Public Sub VBA100本ノック_025()

   Dim wsRec As Worksheet
   Set wsRec = ThisWorkbook.Worksheets("売上")
   
   Dim arRec As Variant
   arRec = wsRec.Range("A1").CurrentRegion.Value
   
   Dim arDB() As Variant
   ReDim arDB(1 To (UBound(arRec, 1) - 1) * (UBound(arRec, 2) - 2), 1 To 4)
   
   Dim rw As Long
   Dim cl As Long
   Dim cntRow As Long
   
   For rw = 2 To UBound(arRec, 1)
       If arRec(rw, 1) = "" Then
           arRec(rw, 1) = arRec(rw - 1, 1)
       End If
       
       For cl = 3 To UBound(arRec, 2)
           cntRow = cntRow + 1
           arDB(cntRow, 1) = arRec(rw, 1)
           arDB(cntRow, 2) = arRec(rw, 2)
           arDB(cntRow, 3) = arRec(1, cl)
           arDB(cntRow, 4) = arRec(rw, cl)
       Next
   Next

   Dim wsDB As Worksheet
   Set wsDB = ThisWorkbook.Worksheets("売上DB")
   
   wsDB.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
   wsDB.Range("A2").Resize(UBound(arDB, 1), UBound(arDB, 2)).Value = arDB

End Sub

業務あるある。この「売上」シートのような状態のデータ、よくあります。何ならまだマシな方。
だいたい配列で処理してしまうことが多いです。取得するデータ（＝貼り付けるデータ）が多くてもすっきり。

26本目。

Public Sub VBA100本ノック_026()

   Dim ws As Worksheet
   Set ws = ThisWorkbook.Worksheets("ファイル一覧")
   
   Dim sFolderPath As String
   
   With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show = True Then
           sFolderPath = .SelectedItems(1)
       End If
   End With
   
   If sFolderPath <> "" Then
       Dim oFSO As Object
       Set oFSO = CreateObject("Scripting.FileSystemObject")
       
       ws.Range("A1").CurrentRegion.Offset(1, 0).Clear
       
       Dim f As Object
       Dim rw As Long
       For Each f In oFSO.GetFolder(sFolderPath).Files
           rw = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
       
           Select Case oFSO.GetExtensionName(f.Name)
           Case "xls", "xlsx", "xlsm"
               ws.Hyperlinks.Add ws.Cells(rw, 1), f.Path, , , f.Name
           Case Else
               ws.Cells(rw, 1).Value = f.Name
           End Select
           
           ws.Cells(rw, 2).Value = f.DateLastModified
           ws.Cells(rw, 3).Value = f.Size
       Next
   End If

End Sub

フォルダ選択ダイアログ、使ったことは一応あるもののやり方はもちろん忘れているのでググりました。
ハイパーリンクもVBAであんまり使うことがないのでググる。FSOは使い慣れているけれどもDateLastModifiedプロパティとか暗記できていないのでこれも。
ハイパーリンクの指定が無ければWSHでDirコマンドとかWhereコマンド飛ばして取得できるかもとか考えたけどどうだろう。（取得できたとしても結局Excelファイルのみまたハイパーリンク貼らないといけなくて面倒なのでやめました）

27本目。

Public Sub VBA100本ノック_027()

   Dim ws As Worksheet
   Set ws = ActiveSheet
   
   Dim h As Hyperlink
   For Each h In ws.Hyperlinks
       If h.Type = msoHyperlinkRange Then
           h.Range.Offset(0, 1).Value = h.Address
           h.Delete
       End If
   Next

End Sub

＜失念ポイント＞Hyperlink.Typeが分からなかったので、「※図は無視してください」の部分を反映できていなかった。
使わない部分は「HyperlinkはTypeプロパティがある」みたいな発想もないので、こういう抜けが発生しがち。

28本目。

Public Sub VBA100本ノック_028()

   Dim wb As Workbook
   Set wb = ActiveWorkbook
   
   Dim msgError As String
   Dim msgExist As String
   
   Dim ws As Worksheet
   For Each ws In wb.Worksheets
       Dim sFolderPath As String
       sFolderPath = ThisWorkbook.Path & "\" & Split(ws.Name, "_")(0)
       If Dir(sFolderPath, vbDirectory) = "" Then
           MkDir sFolderPath
       End If
       
       Dim sFilePath As String
       sFilePath = sFolderPath & "\" & ws.Name & ".xlsx"
       If Dir(sFilePath) <> "" Then
           Dim iAns As Integer
           iAns = MsgBox(Dir(sFilePath) & "はすでに存在しています。上書きしますか？", vbOKCancel, "確認")
           If iAns = vbOK Then
               On Error Resume Next
               Kill sFilePath
               If Err.Number > 0 Then
                   msgError = msgError & vbCrLf & "・" & Dir(sFilePath)
               End If
               On Error GoTo 0
           Else
               msgExist = msgExist & vbCrLf & "・" & Dir(sFilePath)
           End If
       End If
       
       If Dir(sFilePath) = "" Then
           ws.Copy
           ActiveWorkbook.SaveAs sFilePath
           ActiveWorkbook.Close
       End If
   Next
   
   If msgError <> "" Then
       msgError = "以下のファイルで上書きできませんでした。" & msgError
   End If
   
   If msgExist <> "" Then
       msgExist = "以下のファイルは上書きをしませんでした。" & msgExist
   End If
   
   If msgError & msgExist = "" Then
       Exit Sub
   End If
   
   MsgBox msgExist & vbCrLf & vbCrLf & msgError

End Sub

業務で割と使うものなので、今回はきもちエラー回りも記述。しかしこれでも不足はありそう。

29本目。

Public Sub VBA100本ノック_029()

   Dim sFilePath As String
   sFilePath = Application.GetOpenFilename("画像ファイル(*.png;*.jpg),*.png;*.jpg")

   If Dir(sFilePath) = "" Then
       Exit Sub
   End If
   
   Dim rng As Range
   Set rng = ActiveCell
   
   Dim shp As Shape
   Set shp = rng.Parent.Shapes.AddPicture(sFilePath, msoFalse, msoCTrue, 0, 0, 0, 0)
   
   With shp
       .ScaleHeight 1, msoTrue
       .ScaleWidth 1, msoTrue
       .LockAspectRatio = msoCTrue
       .Placement = xlMoveAndSize
       
       If .Width > rng.Width Then
           .Width = rng.Width
       End If
       If .Height > rng.Height Then
           .Height = rng.Height
       End If
       
       .Left = rng.Left + (rng.Width - .Width) / 2
       .Top = rng.Top + (rng.Height - .Height) / 2
   End With
   
End Sub

ほんっとうに時間かかった。1時間近くやっていたのでは。
画像の追加をVBAでやることがまず業務でなかったので、ググって例文コピペして動作確認から。何とかそれっぽくなったあとで、解答を見ました。
Placementプロパティのみ、参照した例文に記載がなかったので解答をみてから書き足した部分。
あとはおおむね解答に添う記載ができたかと思ったけれども、なぜか解答では「If .Width > rng.Width -2 Then」と「-2」しており、この-2が何に由来するものなのかは解読できませんでした…。

30本目。

Public Sub VBA100本ノック_030()

   Dim wsList As Worksheet
   Set wsList = ThisWorkbook.Worksheets("名簿")
   
   With wsList
       Dim rowEnd As Long
       rowEnd = .Cells(.Rows.Count, 1).End(xlUp).Row
       
       Dim rowCnt As Long
       rowCnt = WorksheetFunction.RoundUp((rowEnd - 1) / 2, 0) * 2
   
       Dim arList() As Variant
       ReDim arList(1 To rowCnt, 1 To 2)
       
       Dim rw As Long
       Dim cntRow As Long
       For rw = 2 To rowEnd
           If rw Mod 2 = 0 Then
               cntRow = cntRow + 1
               arList(cntRow, 1) = .Cells(rw, 2).Value
               arList(cntRow + 1, 1) = .Cells(rw, 3).Value
           Else
               arList(cntRow, 2) = .Cells(rw, 2).Value
               arList(cntRow + 1, 2) = .Cells(rw, 3).Value
               cntRow = cntRow + 1
           End If
       Next
   End With
  
   Dim wsPlate As Worksheet
   Set wsPlate = ThisWorkbook.Worksheets("名札")
   
   With wsPlate
       .Cells.ClearContents
       If .UsedRange.Rows.Count > 3 Then
           .UsedRange.Offset(2, 0).Clear
       End If
       
       With .Range("A1").Resize(UBound(arList, 1), UBound(arList, 2))
           .Value = arList
           
           .Resize(2, 2).Copy
           .PasteSpecial xlPasteFormats
           Application.CutCopyMode = False
       End With
   End With

End Sub

意外と名札を作る機会はあります。名札じゃなくても、封筒に貼る住所で名札シール使ってたりもするので。
そういうのは大体1ページあたりの名札枚数が決まっているので、数式を組み込んでおいてVBAで行だけずらすみたいなやり方をすることが多いです。なのでフォーマットもいじらない。
今回はフォーマットも臨機応変にということなので、このような感じに。配列を使うとちょっといきいきします。

■30本目を終えて

「あ！これ業務でやったことある！」な設問と、「全然使ったことないわ…」な設問での差が個人的には大きかった。もちろん発想としては不十分な箇所はあるとはいえ、使い慣れているというか実際の使用場面に心当たりがあるのでエラー原因にも思い至りやすいようで。
VBA自体の経験をもっと積めば、使ったことのない動作に関しても「これにはこういうプロパティ／メソッドがあるはず…」とか予測して色々考えられたりできるようになるでしょうか。ううん。奥が深い。