指定した原紙シートをコピーして新たなシートを作成し、シート名を指定した名前に変更し、その中の指定アドレスに指定配列を丸ごと貼り付けてついでに列幅まで調整したうえでテーブル化し、最後にそのテーブルを戻り値とする関数

過去に作成して提供した、Excelツールの改修を依頼された。作ったのは、２年ほど前か。中身を見て、愕然とする。その作りの、何と酷いことよ。

その中で、結構な行数を費やしている箇所があった。

1. ある範囲のデータを、配列に格納する。
2. 「原紙」シートをコピーする。
3. コピーしたシートの名前を、そのデータに合わせて変更。
4. 指定したセルを起点として、その配列を貼り付ける。
5. 貼り付けたデータをテーブル書式に変更する。
6. そのテーブルを変数にセットする。
7. テーブルに対し、色々と操作する（以降 省略）

再現すると、こんな感じか。

Sub Abe_shi()
    Dim arr() As Variant
        arr = Sheets("生データ").Range("A1:C3").Value
        
        Sheets("原紙").Copy After:=Sheets(Sheets.Count)
    Dim Sh As Worksheet
    Set Sh = ActiveSheet
        Sh.Name = "入荷レポート"
        
        Sh.Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Sh.ListObjects.Add(xlSrcRange, Sh.UsedRange, , xlYes).Name = "テーブル1"

        Sh.Cells.EntireColumn.AutoFit

    Dim Tb As ListObject
    Set Tb = Sh.ListObjects(1)
        Tb.ListColumns("入荷日").DataBodyRange.NumberFormatLocal = "m/d"
End Sub

何だかいつも、似たようなことを繰り返している。
そう思った瞬間、強烈に嫌になった。そこで、先日の配列貼り付けマクロをさらに拡張してみた。

' destination As String 貼り付け先アドレス　例．A1
' sheet_name As String　貼り付け先シート名
'   無指定の場合・・・ActiveSheet
'   既存名を指定・・・指定名のシート
'   指定名が無い・・・指定名で新規シートを作成
' copy_sheet As Boolean 指定シートをコピーしたうえで貼り付けるか
' new _name As String コピーしたシートの名前
'   無指定の場合・・・Excelがコピーした際につけた名前のままとなる
' paste_type as PasteType テータまたはテーブルを選択
' column_autofit As Boolean 貼り付け後の列幅自動調整
' 配列をシートへ貼り付け。
Public Function PasteArray(destination As String, _
                  Optional sheet_name As String = vbNullString, _
                  Optional copy_sheet As Boolean = False, _
                  Optional new_name As String = vbNullString, _
                  Optional paste_type As PasteType = ptRange, _
                  Optional column_autofit As Boolean = False) As Variant

    Dim Ws As Worksheet
    Dim Sh As Worksheet
        ' シート名の指定がない場合、
        If sheet_name = vbNullString Then

        ' ActiveSheetにそのまま貼り付ける場合と、原紙シートのようなものを
        ' コピーして使用する場合で分岐。
            Select Case copy_sheet
                Case False
                    Set Sh = ActiveSheet
                Case True
                    ActiveSheet.Copy After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                    If new_name <> vbNullString Then
                        Sh.Name = new_name
                    End If
            End Select

        ' シート名の指定があって、かつシートが存在する場合、そのシートに貼り付ける｡
        ' ただし、copy_sheetフラグがTrueの場合は、そのシートをコピーしたうえで貼り付ける｡
        ' シート名の指定があって、かつシートが存在しない場合、シートを新規作成する｡
        Else
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Select Case copy_sheet
                        Case False
                            Set Sh = Ws
                        Case True
                            Ws.Copy After:=Sheets(Sheets.Count)
                            Set Sh = ActiveSheet
                            If new_name <> vbNullString Then
                                Sh.Name = new_name
                            End If
                    End Select
                    Exit For
                End If
            Next
            If Sh Is Nothing Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Set Sh = ActiveSheet
                    Sh.Name = sheet_name
            End If
        End If

    Dim DestinationRange As Range
    On Error Resume Next
    Set DestinationRange = Sh.Range(destination)
    On Error GoTo 0

    If Err.Number <> 0 Then
        MsgBox "貼り付け先のアドレス指定に誤りがあるため、処理を中断します｡ "
        Exit Function
    End If

    ' 指定範囲に配列を貼り付け。
    Dim TargetRange As Range
    Set TargetRange = DestinationRange.Resize(rMax - rMin + 1, cMax - cMin + 1)
        TargetRange = source_array

    ' 貼り付けタイプがテーブルの場合、貼り付けたデータをテーブルに
    ' 変更したうえで、戻り値を同テーブルとする。
    If paste_type = ptTable Then
        Dim TableName As String
            TableName = "Table_" & Format(Now, "yyyymmdd_hhmmss")

            Sh.ListObjects.Add(xlSrcRange, _
                                        TargetRange.CurrentRegion, _
                                        , _
                                        xlYes).Name = TableName
            Set PasteArray = Sh.ListObjects(TableName)
    Else
    ' 貼り付けタイプが範囲の場合、戻り値を貼り付け先シートとする。
        Set PasteArray = Sh
    End If

    If column_autofit Then
        TargetRange.EntireColumn.AutoFit
    End If

End Function

すると、先程のマクロは、ここまで短くなった。

Sub Abe_shi()
    Dim arr() As Variant
        arr = Sheets("生データ").Range("A1:C3").Value
    
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    Dim Tb As ListObject
    Set Tb = SQC.TargetArray(arr).PasteArray("A2", "原紙", True, "入荷レポート", ptTable, True)
        Tb.ListColumns("入荷日").DataBodyRange.NumberFormatLocal = "m/d"
End Sub

正味、９行掛けていた個所が、４行になった。その分、クラスモジュール側のマクロが更に膨れ上がってしまったが、個人的には何かと流用が効きそうなので、良しとしよう。

クラスモジュールの全文はこちら。
infoment.hatenablog.com

参考まで。

配列内の文字を複数条件で置換

文字を置換したい。シート上であれば、これで片が付く。

だが今回は配列内の文字に対し、複数条件で置換したい。挑戦してみた。

折角なので、先日来作成しているArrayEditClassの機能拡張で対応してみた。
作戦は、こうだ。

1. ParamArrayキーワードで、置換前後の文字列を受け取る。
2. 受け取った文字で、配列内を置換（ローラー作戦）。

ということで、手法はとっても原始的。
しばらく捏ね繰り回してみて、できた結果がコチラ。

' 配列内の文字列置き換え。
' 置換前と置換後の文字を列記して、ParamArrayキーワードで配列として受け取る。
' ０，２，４，６・・・番目が置換前
' １，３，５，７・・・番目が置換後
' となる。組合せは（０，１），（２，３）・・・の順。
Public Function MultipleSubstitution(ParamArray str()) As Variant
    ' 置換前と置換後の組合せ数を、配列の最大数÷２から求める。
    ' ※引数が奇数個の場合を想定して、RoundDown関数で切り捨て。
    ' ※その場合、最後に指定した文字はvbNullstringと置換される。
    Dim iMax As Long
        iMax = WorksheetFunction.RoundDown(UBound(str) / 2, 0)
    
    ' 置換前文字。
    Dim msWhat() As Variant
    ReDim msWhat(iMax)
    
    ' 置換後文字。
    Dim msReplacement As Variant
    ReDim msReplacement(iMax)
    
    ' 置換前後の文字を配列に格納する。
    ' ※奇数個指定の場合、最後の置換前文字に対する置換後文字が
    ' 　vbNullStringになるよう、エラーを無視させている。
        On Error Resume Next
        For i = 0 To UBound(str)
            msWhat(i) = str(2 * i)
            msReplacement(i) = str(2 * i + 1)
        Next
        On Error GoTo 0
    
    ' 配列内の全ての文字列に対し、置換処理を行う。
        For r = rMin To rMax
            For c = cMin To cMax
                For i = 0 To iMax
                    source_array(r, c) = Replace(source_array(r, c), _
                                                 msWhat(i), _
                                                 msReplacement(i))
                Next
            Next
        Next
        
        MultipleSubstitution = source_array
End Function

早速、いつもの「なんちゃって個人情報」で試してみよう。

今回設定した置換条件は、以下のとおり。

1. ドコモ ⇒ docomo
2. ソフトバンク ⇒ SoftBank
3. ツーカー ⇒ 削除

置換したら、新しいシートに貼り付けてテーブルにする。
なお、ツーカーを削除したことに特別な意味はない。あくまでテストってことで。

Sub abe_shi()
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    Dim arr() As Variant
        arr = ActiveSheet.UsedRange.Value
        arr = SQC.TargetArray(arr).MultipleSubstitution("ドコモ", "docomo", _
                                                        "ソフトバンク", "SoftBank", _
                                                        "ツーカー")
        SQC.TargetArray(arr).PasteArray "A1", "NewSheet", ptTable, True
End Sub

ツーカーは空白文字と置換するので、今回は意地悪テストで引数を省略した。

結果は、以下のとおり。

クラスモジュールの全文（最新版）はこちら。
infoment.hatenablog.com

想定どおりの動きを実現できた。早速、明日からの業務で使えそうだ。
これでまた、更に１分早く帰られるようになって、良かった良かった。

参考まで。

Androidアプリ超入門

買ってしまった。とうとう。ついに。

作って楽しむプログラミング Androidアプリ超入門

やりたいことは幾つかあるが、まずは取り敢えず、本書を最後までやり遂げることを目標にしよう。

1. 一月ぐらいかけて、本書に取り組む
2. 並行して、やりたいことを疑似的に（半ばネタ目的で）Excelで再現
3. １と２を合体

上手くいくかな。
上手くいかなかったら、しれっと、このネタの自然消滅を狙います。

こちらも購入。

【予約&早期購入特典付】いちばんやさしいExcelピボットテーブルの教本 人気講師が教えるデータ集計 が一瞬で終わる方法 (「いちばんやさしい教本」シリーズ)

オススメです。

参考まで。

新規シートを追加してから貼り付け の続き

先日、配列をシートに貼り付ける際、新規シートを追加してから貼り付けられるようにしてみた。
infoment.hatenablog.com

このマクロには問題があった。例えば配列を「新規シートのA1」に貼り付ける際、引数を渡した時点で「新規シートのA1」は存在しないため、新規シートを追加したのちにセットし直す必要があったのだ。この点について二人の方から、ご指摘・ご助言も頂いた。

そこで、次のとおり作り直すことにした。

1. 貼り付け先の指定（引数）は、Rangeではなく、Addressとする。
2. 貼り付け先のシートを指定しない場合、ActiveSheetを貼り付け先とする。
3. 貼り付け先のシートをシート名で指定した際、当該シートが存在しない場合、同名のシートを新規に作成して貼り付ける。
4. ついでに、貼り付け後の列幅調整を引数に追加。

以上を踏まえると、↓ こんな感じだ。

' destination As String 貼り付け先アドレス　例．A1
' sheet_name As String　貼り付け先シート名
'   無指定の場合・・・ActiveSheet
'   既存名を指定・・・指定名のシート
'   指定名が無い・・・指定名で新規シートを作成
' paste_type as PasteType テータまたはテーブルを選択
' column_autofit As Boolean 貼り付け後の列幅自動調整
' 配列をシートへ貼り付け。
Public Function PasteArray(destination As String, _
                  Optional sheet_name As String = vbNullString, _
                  Optional paste_type As PasteType = ptRange, _
                  Optional column_autofit As Boolean = False) As ListObject

    Dim Ws As Worksheet
    Dim Sh As Worksheet
        ' シート名の指定がない場合、アクティブシートに貼り付け。
        If sheet_name = vbNullString Then
            Set Sh = ActiveSheet
        ' シート名の指定があって、かつシートが存在する場合、そのシートに貼り付ける。
        ' シート名の指定があって、かつシートが存在しない場合、シートを新規作成する。
        Else
            For Each Ws In Worksheets
                If Ws.Name = sheet_name Then
                    Set Sh = Ws
                    Exit For
                End If
                If Sh Is Nothing Then
                    Sheets.Add After:=Sheets(Sheets.Count)
                    Set Sh = ActiveSheet
                        Sh.Name = sheet_name
                End If
            Next
        End If

    Dim DestinationRange As Range
    On Error Resume Next
    Set DestinationRange = Sh.Range(destination)
    On Error GoTo 0

    If Err.Number <> 0 Then
        MsgBox "貼り付け先のアドレス指定に誤りがあるため、処理を中断します。"
        Exit Function
    End If


    Dim TargetRange As Range
    Set TargetRange = DestinationRange.Resize(rMax - rMin + 1, cMax - cMin+ 1)
        TargetRange = source_array

    If paste_type = ptTable Then
        Dim TableName As String
            TableName = "Table_" & Format(Now, "yyyymmdd_hhmmss")

            ActiveSheet.ListObjects.Add(xlSrcRange, _
                                        TargetRange, _
                                        , _
                                        xlYes).Name = TableName
            Set PasteArray = ActiveSheet.ListObjects(TableName)
    End If

    If column_autofit Then
        TargetRange.EntireColumn.AutoFit
    End If

End Function

暫くこれで運用してみて、何か問題があれば、また改修することにします。

クラスモジュールの全文（最新版）はこちら。
infoment.hatenablog.com

参考まで。

互換モードのExcel（拡張子.xls）を、まとめて「拡張子 .xlsx」に変換

先日は、互換モードのファイルパスを受け取り、以下の拡張子で保存し直すマクロに挑戦した。

• 「.xlsb」（バイナリー　※指定時のみ）
• 「.xlsx」（マクロを含まない場合　※自動判別）
• 「.xlsm」（マクロを含む場合　※自動判別）

infoment.hatenablog.com

今日は、「渡す側」の作成に挑戦する。

作業用に、このようなシートを作成した。

フォルダパスを入力するセルには、予め「FolderPath」と命名してある。
バイナリ形式で保存したい場合のため、チェックボックスを設けた。
バイナリ形式に馴染みが無い方のために、リンクも張っておいた。
https://wa3.i-3-i.info/word15089.htmlwa3.i-3-i.info

B1にフォルダパスを入力して「更新」ボタンを押すと、サブフォルダ内を含め全ての互換モードファイル（拡張子 .xls）を探し出し、新しい拡張子で保存し直す。

以下が、今回作成したもの。更新した結果を二次元配列で返す関数とした。

Function UpdateExtension() As Variant

    ' 画面更新の一時停止。
    Application.ScreenUpdating = False
    ' アラートの一時停止。
    Application.DisplayAlerts = False

    ' ファイルシステムオブジェクト。
    ' ※ファイルの存在確認や拡張子取得用。
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダーパスの取得。
    Dim FolderPath As String
        FolderPath = Range("FolderPath").Value
        If Range("FolderPath") = vbNullString Then
            FolderPath = ThisWorkbook.Path
            Application.StatusBar = "フォルダパスが空欄のため、このファイルの保存パスをフォルダパスに設定しました。"
        ElseIf FSO.FolderExists(FolderPath) = False Then
            FolderPath = ThisWorkbook.Path
            Application.StatusBar = "ご指定のフォルダが存在しないため、このファイルの保存パスをフォルダパスに設定しました。"
        End If
    
    ' 指定フォルダーパス下のファイル名取得。
    ' ※サブフォルダ以下も対象。
    Dim arr As Variant
        arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & FolderPath & """ /b /s /a-d").StdOut.ReadAll, vbCrLf), ".")
    
    ' 更新結果を格納するための配列。
    Dim Result() As Variant
    ReDim Result(1 To UBound(arr) + 2, 1 To 2)
    ' 更新結果のラベル。
        Result(1, 1) = "更新前"
        Result(1, 2) = "更新後"
    
    Dim i As Long
    Dim j As Long: j = 2
        For i = 0 To UBound(arr)
            Application.StatusBar = i + 1 & " / " & UBound(arr) + 1 & " 個目を更新中。"
            If FSO.GetExtensionName(arr(i)) = "xls" Then
                Result(j, 1) = arr(i)
                Result(j, 2) = ToNewExtension(CStr(arr(i)), Sheet1.CheckBox1.Value)
                j = j + 1
            End If
        Next

    UpdateExtension = Result

    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Function

更新ボタンをクリックした際の処理。結果をシートに貼り付けている。

Private Sub CommandButton1_Click()
    
    Dim arr() As Variant
        arr = UpdateExtension
        
        Columns("E:F").ClearContents
        Cells(3, "E").Resize(UBound(arr), 2) = arr
    
End Sub

それでは、テストしてみよう。

まずは、バイナリモードを指定せずに更新。それぞれ、更新に成功した。

次に、バイナリーモードで実行。バイナリーモードの場合、マクロの有無は不問となる。こちらも、更新成功。

ここまで来ると、後は「更新前のファイルをどうするか」になる。一括自動削除は、かなり気が引ける。また、自動削除ボタンも、誤操作が恐ろしい。せいぜい、「更新前ファイル格納フォルダ」を自動作成し、そこに移動させておくぐらいだが・・・責任取れないので、ここでは扱わないことにしよう。

参考まで。

.xls を .xlsb や .xlsm で保存

昨日は、拡張子が「.xls」のファイルが大量にあったため、これを「.xlsx」に自動更新するマクロに挑戦した。
infoment.hatenablog.com

すると、日頃親交のある狸さんから、拡張子「.xlsb」についてご紹介を受けた。
（いつも有難うございます）。

そこで本日は、昨日のコードにチェック機能を幾つか設け、さらに「.xlsb」への更新を追加することに挑戦する。

「.xlsb」は、バイナリ形式とのこと。特に文字列だけのファイルに於いては、その容量および起動速度が優れている（らしい）。

そこで実際、手元にあったファイルで比較してみた。とあるシステムから出力したデータで、13835行×32列ある。結果は、以下のとおり。

拡張子	容量	単位
.xls	11476	kB
.xlsx	2044	kB
.xlsb	672	kB

確かに容量を見れば、圧倒的に有利だ。しかしWebで検索すると、使用については賛否様々な意見があるようで。

そこで取り敢えず、保存形式の選択肢として選べるようにしたうえで、時と場合により、判断はユーザーにお任せすることにした。

以上を踏まえると、今回の作戦は以下のとおり。

1. xlsbにするか否かのフラグを引数に追加する。
2. ファイルの存在確認を追加する。
3. ファイルが処理対象か否かの確認を追加する。
4. 保存予定名のファイルが既に無いかの確認を追加する。
5. 以上を踏まえたうえで、xlsb形式での保存を追加する。

結果は、次のとおり。

Function ToNewExtension(source_path As String, _
               Optional xlsb_flag As Boolean = False) As String
               
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(source_path) = False Then
            ToNewExtension = "指定ファイルは存在しません。"
            Exit Function
        ElseIf FSO.GetExtensionName(source_path) <> "xls" Then
            ToNewExtension = "指定ファイルは処理対象外です。"
            Exit Function
        Else
            Dim str As Variant
                For Each str In Array("x", "m", "b")
                    If FSO.FileExists(source_path & str) Then
                        ToNewExtension = "更新後のファイルが既に存在します。"
                        Exit Function
                    End If
                Next
        End If
               
    Dim Wb As Workbook
    Set Wb = Workbooks.Open(source_path, False, True)
        If xlsb_flag Then
            Wb.SaveAs , xlExcel12
        ElseIf Wb.HasVBProject Then
            Wb.SaveAs , xlOpenXMLWorkbookMacroEnabled
        Else
            Wb.SaveAs , xlOpenXMLWorkbook
        End If
        ToNewExtension = Wb.FullName
        Wb.Close
        
End Function

例によって、また大仕掛けになってきた。今回は、どこまで膨れ上がることやら。

明日に続きます。

参考まで。

.xls を .xlsx で保存

あるシステムからダウンロードしたExcelファイルが、拡張子「.xls」だった。一月に一ファイルで、３年分ある。なぜか開くのに時間が掛かるし、容量も大きい。

そこで、一つずつ開いては「.xlsx」で保存する地味な作業に突入して、二つ目で嫌になった。そうだ、マクロにやってもらおう。

まずは、開いて閉じるところだけ作ろう。作戦は、こうだ。

1. 受け取ったパスに存在するExcelファイルを開く
   開くとき、リンクは更新しない。
   また、元ファイル保護のため読み取り専用で開く。
2. マクロが含まれているか否かを確認。
3. ２．の結果によって、「.xlsx」または「.xlsm」で保存。
4. 開いたファイルを閉じる。

今回は、以下のチェックを割愛した。

1. ファイルの存在確認。無いものは開けない。
2. 拡張子が「.xls」かどうかの確認。それ以外なら、開く必要がない。
3. 保存するファイルの存在確認。既に存在するなら、上書きしてはいけない。

今日は取り敢えず、基礎工事だけ。上記チェックは、後日取り組む。

ということで上記を踏まえ、作成したのがこちら。

Function ToNewExtension(source_path As String) As String
    Dim Wb As Workbook
    Set Wb = Workbooks.Open(source_path, False, True)
        If Wb.HasVBProject Then
            Wb.SaveAs , xlOpenXMLWorkbookMacroEnabled
        Else
            Wb.SaveAs , xlOpenXMLWorkbook
        End If
        ToNewExtension = Wb.FullName
        Wb.Close
End Function

何かと必要になると思ったので、更新後のファイル名を返す関数にしてみた。
さて、ここからどう肉付けするか。

明日からまた、思案のしどころです。

参考まで。