2022-02-24

VBA100本ノック 23本目：シート構成の一致確認

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220224232745p:plain

シート名のみ、位置は不問ということなので、シート名を辞書に
登録して比較することとした。

一つ目のブックを開いて、シート名で辞書を作成。
二つ目のブックを開いて、各シートと辞書を比較。
シート名が辞書にあるなら、辞書からシート名を除去する。
シート名が辞書にないなら、その時点で不一致確定。
二つ目のブックのシート名を一通り確認して、辞書が空になれば一致。
何か余っていれば、不一致。

ということで、作成したのがこちら。

Sub VBA_100Knock_023()
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim FilePath(1) As String
        FilePath(0) = ThisWorkbook.Path & "\Book_20201101.xlsx"
        FilePath(1) = ThisWorkbook.Path & "\Book_20201102.xlsx"

    Dim Wb(1) As Workbook
    Set Wb(0) = Workbooks.Open(FilePath(0), False, True)
    Set Wb(1) = Workbooks.Open(FilePath(1), False, True)
    
    Dim Ws As Worksheet
        For Each Ws In Wb(0).Worksheets
            ' ありなし確認のための辞書なので、Item不問。
            ' 今回はTrueとした（何でも良い）。
            Dict(Ws.Name) = True
        Next
        Wb(0).Close False
        
        For Each Ws In Wb(1).Worksheets
            If Dict.Exists(Ws.Name) Then
                Dict.Remove Ws.Name
            Else
                Wb(1).Close False
                MsgBox "不一致"
                Exit Sub
            End If
        Next
        
        If Dict.Count = 0 Then
            MsgBox "一致"
        Else
            MsgBox "不一致"
        End If
        
        Wb(1).Close False
End Sub

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-02-21

VBA100本ノック 22本目：FizzBuzz発展問題

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220221231720p:plain

よく見かけるFizzBuzz問題と言えば、例えばイミディエイトウィンドウに結果を
出力するなどだろうか。今回は、結果によって出力する列を変えていることで、
発展的な問題となっている。

Sub VBA_100Knock_022()
    Dim arr() As Variant
    Dim iMax As Long: iMax = 100
    ReDim arr(1 To iMax, 1 To 4)
    Dim i As Long
    Dim j As Long
    Dim Result As Variant
        For i = 1 To iMax
            If i Mod 15 = 0 Then
                j = 4: Result = "FizzBuzz"
            ElseIf i Mod 5 = 0 Then
                j = 3: Result = "Buzz"
            ElseIf i Mod 3 = 0 Then
                j = 2: Result = "Fizz"
            Else
                j = 1: Result = i
            End If
            arr(i, j) = Result
        Next
        
        Range("A1").Resize(iMax, 4) = arr
End Sub

実行した結果がこちら。
f:id:Infoment:20220221232328p:plain

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-02-19

VBA100本ノック 21本目：バックアップファイルの削除

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220219210722p:plain

前回はバックアップを一つ作るだけだったが、今回は最新の30個を残すとのこと。
そこで前回の解答を応用して、まずバックアップを50個作ることにした。

Sub VBA_100Knock_20の応用()
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' BACKUPフォルダの存在確認。無ければ作る。
    Dim BackupFolderPath As String
        BackupFolderPath = ThisWorkbook.Path & _
                           "\" & "BACKUP"
        If Not FSO.FolderExists(BackupFolderPath) Then
            MkDir BackupFolderPath
        End If
        
    Dim BackupFileName As String
    Dim i As Long
        For i = 1 To 50
            BackupFileName = FSO.GetBaseName(ThisWorkbook.Name) & _
                             Format(Now, "_yyyymmddhhmmss") & ".xlsm"
            
            ThisWorkbook.SaveCopyAs BackupFolderPath & "\" & _
                                    BackupFileName
        
            Application.Wait [Now()+"00:00:01"]
        Next
End Sub

バックアップが出来たところで、今回の作戦はこうだ。

バックアップファイルの数値をキーに、どうファイルのパスをアイテム
として、辞書を作成する。
辞書のキー情報（配列）の最小値を求め、それに対応するパスを削除する。
削除したキーを辞書から除去する。
キーの数が残り三十個になるまで、これを繰り返す。

以上を踏まえて作成したのがこちら。

Sub VBA_100Knock_21()
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' BACKUPフォルダの存在確認。
    Dim BackupFolderPath As String
        BackupFolderPath = ThisWorkbook.Path & _
                           "\" & "BACKUP"
        If Not FSO.FolderExists(BackupFolderPath) Then
            MsgBox "バックアップフォルダは存在しません。"
            Exit Sub
        End If
        
    ' BACKUPファイルの確認。
    ' バックアップの日付とパスで辞書を作成する。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim File As Scripting.File
    Dim myReg As VBScript_RegExp_55.RegExp
    Set myReg = New VBScript_RegExp_55.RegExp
        myReg.Pattern = ".*_(\d{12,14})\.xls\w?"
    Dim MC As VBScript_RegExp_55.MatchCollection
        For Each File In FSO.GetFolder(BackupFolderPath).Files
            If myReg.Test(File.Name) Then
                Set MC = myReg.Execute(File.Name)
                Dict(CDbl(MC(0).SubMatches(0))) = File.Path
            End If
        Next

    ' 日付を14桁の数値としたもの。Long型はオーバーフローする。
    Dim OldDate As Double
        Do
            If Dict.Count <= 30 Then
                Exit Do
            End If
            OldDate = WorksheetFunction.Min(Dict.Keys)
            Kill Dict(OldDate)
            Dict.Remove OldDate
        Loop
End Sub

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-02-07

VBA100本ノック 20本目：ブックのバックアップ

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220207220226p:plain

どの時点での最新版かをファイル名に持たせる場合、日時だけでなく
時分秒の情報を含ませるのは、良くあることで。更新頻度が高くない
ならば、今回のお題のとおり、時分だけでも充分と思われる。

Sub VBA_100Knock_020()
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' BACKUPフォルダの存在確認。無ければ作る。
    Dim BackupFolderPath As String
        BackupFolderPath = ThisWorkbook.Path & _
                           "\" & "BACKUP"
        If Not FSO.FolderExists(BackupFolderPath) Then
            MkDir BackupFolderPath
        End If
        
    ' BACKUPファイルの作成。
    Dim BackupFileName As String
        BackupFileName = FSO.GetBaseName(ThisWorkbook.Name) & _
                         Format(Now, "_yyyymmddhhmm") & _
                         ".xlsm"
        
        ThisWorkbook.SaveCopyAs BackupFolderPath & "\" & _
                                BackupFileName
End Sub

今回は、事前にMicroSoft Scripting Runtimeを参照設定したうえで、
変数FSOを宣言した。FileSystemObjectはとても便利なので、お勧めです。

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-02-04

VBA100本ノック 19本目：図形のコピー

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220204232800p:plain

オートシェイプのコピーということで、今回はDuplicateメソッドを使用する。
シート内のShapeをループで虱潰しにコピーする作戦だが、問題文にもある
とおり、入力規則のリストもこれに引っかかってコピーされてしまう。

そこで今回は、リストの名前決め打ちで、コピー対象から除外することにした。

Sub VBA_100Knock_019(ws As Worksheet)
    Dim Shape As Excel.Shape
    Dim CopiedShape As Excel.Shape
        For Each Shape In ws.Shapes
            If Not Shape.Name Like "Drop Down*" Then
                Set CopiedShape = Shape.Duplicate
                CopiedShape.Left = Shape.Left + Shape.Width
                CopiedShape.Top = Shape.Top
            End If
        Next
End Sub

なお、コピー直後のオートシェイプがどこに配置されるか、よく解らなかった。
そこで適当にコピーした後に、目的の位置に移動させることとした。

解答を実行した結果がこちら。
f:id:Infoment:20220204233506g:plain

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。

2022-02-02

取り消し線が設定された範囲の文字を除去したい

Excel VBA 作ってみた

先日、こんな相談を受けた。

「Excelで、文字列の一部に取り消し線が設定されているのですが、
その部分だけ除去して別のセルにコピーできませんか？」

ということで、挑戦してみた。
f:id:Infoment:20220202225534p:plain

依頼内容を視覚化すると、↓ こんな感じだ。
f:id:Infoment:20220202225248p:plain

取り消し線が付された文字を除去したい。
文字が全て除去された行は、改行も除去したい。
余分な改行も除去したい。

作成したものから、上記内容のみ抜き出して再構築したのがこちら。

Sub 取消範囲除去(src_range As Range, _
                 dst_range As Range)
    ' 取消範囲除去前の文字列。
    Dim Src As String
        Src = src_range.Value
    ' 除去後の文字列格納用変数。
    Dim Dst As String
    Dim i As Long
        ' 取り消し線が付されていない文字のみ、
        ' Dstへ追加する（※改行も含まれる）。
        For i = 1 To Len(Src)
            If Not src_range.Characters(i, 1) _
                        .Font.Strikethrough Then
                Dst = Dst & Mid(Src, i, 1)
            End If
        Next
        
        ' 正規表現。
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        ' ２回以上連続する改行でマッチ。
        myReg.Pattern = "\n{2,}"
        myReg.Global = True
        
        ' ２回以上連続する改行を一つの改行に置き換える
        ' ことで、全ての文字が除去された行を削除する。
        If myReg.Test(Dst) Then
            Dst = myReg.Replace(Dst, vbNewLine)
        End If
        
        dst_range = Dst
End Sub

実行した結果がこちら。
f:id:Infoment:20220202230318g:plain

依頼をくださった方に渡したところ、大変喜んでもらえたので良かった。

参考まで。

2022-01-31

VBA100本ノック 18本目：名前定義の削除

Excel VBA 100本ノック

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220131204720p:plain

参照範囲に「#REF!」が含まれるのは、良くあることで。しかも自分以外が
作成したファイルで起こると、気づきないまま増殖していることも。

今回は、名前の値に「#REF!」が含まれるか否かで判別することとした。
なお、判別はLike演算子で行い、#と!は[]で括ることでエスケープしている。

Sub VBA_100Knock_018()
    Dim 名前 As Excel.Name
    Dim 非表示件数 As Long
    Dim 削除件数 As Long
        For Each 名前 In ActiveWorkbook.Names
            ' 非表示があれば表示してカウント。
            If Not 名前.Visible Then
                名前.Visible = True
                非表示件数 = 非表示件数 + 1
            End If
            
            ' 参照エラーがあれば削除してカウント。
            If 名前.Value Like "*[#]REF[!]*" Then
                名前.Delete
                削除件数 = 削除件数 + 1
            End If
        Next
        
        Debug.Print Format(非表示件数, "非表示件数：00件")
        Debug.Print Format(削除件数, "削除件数　：00件")
End Sub

解答を実行した結果がこちら。
f:id:Infoment:20220131210030p:plain

※冒頭リンク先の解答例および解説も、ぜひご一読ください。

参考まで。