配列からの値貼り付けに関する覚書 ③ ところどころに数式を含むテーブルに、レコードを丸ごとベタッと貼り付けたい

先日、四苦八苦した体験談からのご紹介。
f:id:Infoment:20210315222049p:plain

例えば、こんなテーブルがあるとする。
f:id:Infoment:20210315222817p:plain

このテーブル、実は年齢の列だけ数式がセットされている。
f:id:Infoment:20210315222935p:plain

このような条件のもと、レコードを追加したい。
f:id:Infoment:20210315223041p:plain

例えば、この追加レコードを配列に格納して、テーブルに
ベタっと追加したらどうなるか。

Sub Test()
    
    ' 貼り付け先。
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' 貼り付け元。
    Dim SourceArray As Variant
        SourceArray = Range("A17:D18")
    
    ' テーブルに行追加。
    Dim LastRow As Excel.ListRow
    Set LastRow = Tb.ListRows.Add
    
    ' 最終行を配列の行数だけ拡張した範囲に貼り付け。
        LastRow.Range.Resize(UBound(SourceArray)) = SourceArray

End Sub

結果は、こんな感じ。貼り付けたレコードのうち、一つ目だけ
空白であることが律儀に守られている。
f:id:Infoment:20210315223725p:plain

ならば、一行目だけ数式を無理矢理セットしたらどうかと考えた。

Sub Test()
    
    ' 貼り付け先。
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' 貼り付け元。
    Dim SourceArray As Variant
        SourceArray = Range("A17:D18")
    
    ' テーブルに行追加。
    Dim LastRow As Excel.ListRow
    Set LastRow = Tb.ListRows.Add
    
    ' 追加された行から数式を取得。
    Dim ColumnIndex As Long
        For ColumnIndex = 1 To Tb.ListColumns.Count
            If LastRow.Range(ColumnIndex).HasFormula Then
                SourceArray(1, ColumnIndex) = LastRow.Range(ColumnIndex).Formula
            End If
        Next
        
    ' 最終行を配列の行数だけ拡張した範囲に貼り付け。
        LastRow.Range.Resize(UBound(SourceArray)) = SourceArray

End Sub

結果、今度はちゃんと数式がセットされた。
f:id:Infoment:20210315224446p:plain

数式を取得してセットする手間はあるが、ベタっと貼り付けられるので
なかなか便利だと思った。実際この方法を採用するかどうかは、いつも
のごとく、時と場合と皆様のお好みで。

参考まで。

複数あるExcelファイルを開いて列幅調整

先日、このような困りごとをお見掛けした。

  1. システムから吐き出された複数のExcelファイルがある。
  2. 機械的に吐き出されているため、列幅未調整で、文字が見切れている。
  3. これらのファイル全てについて、列幅を自動調整する必要がある。

挑戦してみた。
f:id:Infoment:20210305221541p:plain

まず、いつもの「なんちゃって個人情報」から、対象となるファイルっぽい
ものを作成してみた。
f:id:Infoment:20210305221657p:plain

中身は、こんな感じだ。
f:id:Infoment:20210305221730p:plain

今回は、こんな作戦で行ってみよう。
まず、サブプロシージャは二つ作成する。

  1. ファイル内の列幅調整用。
  2. 複数ファイルに対する処理ループ用。

列幅調整については、セル内で折り返されている場合を考慮して、
一旦びよーんと伸ばしてから自動調整してみよう。

まず、繰り返し処理用サブプロシージャがこちら。

Sub 繰り返し処理()
    
    Application.ScreenUpdating = False

    ' ファイルが保存されているところ。
    Dim FolderPath As String
        FolderPath = "C:\Temp"
        
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim File As Object
    Dim Wb As Workbook
    Dim NewName As String
    
    ' FolderPath内のファイルを一つずつ取り出して処理。
        For Each File In FSO.GetFolder(FolderPath).Files
            Set Wb = Workbooks.Open(File.Path)
            ' 編集後のファイル名。
                NewName = FSO.GetParentFolderName(File) & "\" & _
                          FSO.GetBaseName(File) & _
                          "_列幅調整済み.xlsx"
            ' 列幅調整用サブプロシージャ呼び出し。
            Call 列幅調整(Wb, NewName)
        Next
    
    Application.ScreenUpdating = False
    
End Sub

次に、開かれたファイルの列幅を調整する。ただし、以下を前提とする。

  1. 各ファイル内の対象シートは一つのみ。
  2. 調整後のファイルは、別名保存する。

こんな感じだ。

Sub 列幅調整(Wb As Workbook, new_name As String)
    If Wb Is Nothing Then Exit Sub
    
    With Wb.Sheets(1).Cells
    
        ' セル内で折り返されている場合を想定して、
        ' 一旦思い切り列幅を伸ばす。
        .ColumnWidth = 100
    
        ' 列幅と行高さを自動調整。
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        
    End With
    
    ' 別名保存。
    Wb.Close SaveChanges:=True, _
             Filename:=new_name
End Sub

実行してみると、各ファイルの編集後ファイルが作成されている。
f:id:Infoment:20210305224857p:plain

中身の調整も、上手く行ったようだ。
f:id:Infoment:20210305224948p:plain

なお、上記を実際に使用する場合は、編集後と同じ名前のファイル名が
既に存在する場合の処理も必要かもしれません。

参考まで。

配列からの値貼り付けに関する覚書 ② 値と数式の混在は成立しない場合がある(失敗談)

先日体験した失敗談からのご紹介。
f:id:Infoment:20210301225941p:plain

例えば、こんなテーブルでのお話。
f:id:Infoment:20210301230050p:plain

納期は基本的に、発注日の14日後だ。
f:id:Infoment:20210301230149p:plain

ところが、このテーブルの使用者から、こんな要望が寄せられた。

  1. 果物によっては、納期が変わる場合があって、納期のセルを上書きしたい。
  2. 上書きの条件は複数様々あり、定まっていない。
  3. 手入力用の列は設けたくない。

列の内容が数式と手書きで混在するなどやりたくなかったが、要望だから
仕方がない。とここで、閃いた。例えば、こんな方法はどうだろう?

  1. 納期列に値を張り付けるための配列を準備する。
  2. もともと設定されていた数式を取得する。
  3. 各行をループし、上書き条件を満たす場合は値を、
    それ以外の場合は数式をセットする。
  4. 3.を列に貼り付ける。

これは、我ながら中々の名案だと思った。早速試してみよう。今回は試しに、
「みかん」の時だけ納期を発注日の1週間後にしてみた。

Sub Test()
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' 値貼り付け先の範囲を設定。
    Dim TargetRange As Range
    Set TargetRange = Tb.ListColumns("納期").DataBodyRange
    
    ' もともと設定されている式を取得。
    Dim FormulaText As String
    Dim r As Range
        For Each r In TargetRange
            If r.HasFormula Then
                FormulaText = r.Formula
                Exit For
            End If
        Next
    
    ' 貼り付け用の配列を取得。貼り付け先の範囲を一旦配列に
    ' 格納することで、配列のサイズ調節を省略。
    Dim TargetArray As Variant
        TargetArray = TargetRange
    
    ' 品名が「みかん」のとき、納期を発注日の1週間後に設定。
    ' それ以外の品名ならば、もともとの数式を残しておく。
    Dim i As Long
        For i = 1 To Tb.ListRows.Count
            If Tb.ListRows(i).Range(Tb.ListColumns("品名").Index) = "みかん" Then
                TargetArray(i, 1) = Tb.ListRows(i).Range(Tb.ListColumns("発注日").Index) + 7
            Else
                TargetArray(i, 1) = FormulaText
            End If
        Next
    
    ' 配列を値貼り付け。
        TargetRange = TargetArray
End Sub

さて、実行した結果は・・・何も変わらなかった。どうして?
f:id:Infoment:20210301231228p:plain

貼り付け直前の配列の中身を見ると、「みかん」はちゃんと納期の
1週間後になっている。
f:id:Infoment:20210301231413p:plain

その後の確認で、「みかん」を「りんご」に、つまり配列の先頭が数式でなく
した場合は、意図した結果になることがわかった。
f:id:Infoment:20210301231524p:plain

以上のことから、次のようなルールがあると推測される。

  1. 配列の先頭が数式であって、且つ貼り付け先がテーブルである場合、
    以降の行の値が何であっても、その列は全て先頭の式で満たされる。
  2. 配列の先頭が値である場合、その列は数式と値が混在しうる。

良い方法を見つけたと思ったのだが・・・失敗です。

参考まで。

配列からの値貼り付けに関する覚書 ① Transpose関数とIndex関数は極力使用しない

ここ一週間ほど、(私にとっての)大規模マクロを作成していて、泥沼に
はまっている(絶賛継続中)。

そこから抜け出そうとして得た教訓を一つ二つ、覚書として残しておこう。
f:id:Infoment:20210228085112p:plain

例えば、こんなテーブル。
f:id:Infoment:20210228090824p:plain

これについて「品名列をF2~F4に転記したい」とする。その際、各品名の頭に
「品名:」を追加したい。↓ 完成形は、こんな感じだ。
f:id:Infoment:20210228090906p:plain
今までは、Index関数を用いて配列をスライスし、編集して貼り付けていた。

Sub Test()
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    Dim SourceArray As Variant
        SourceArray = Tb.DataBodyRange
        
    Dim arr As Variant
        arr = WorksheetFunction.Index(SourceArray, 0, 1)
    
    Dim i As Long
        For i = 1 To UBound(arr)
            arr(i, 1) = "品名:" & arr(i, 1)
        Next
        
        Range("F2").Resize(UBound(arr)) = arr
End Sub

ところがレコード数が増えていくうち、何かの都合でIndex関数がエラーを
起こすようになった。
※実際問題が発生したのは、1万行×100列ほどのテーブル。

しかも、昨日までは正常に動いていたのに、何切っ掛けでそうなったか
分からない。

ということで、安定的な動作を目的として、エラー時の原因が特定しにくい
関数は使用しないこととした。

Sub Test()
    Dim Tb As Excel.ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    Dim SourceArray As Variant
        SourceArray = Tb.DataBodyRange
        
    Dim arr() As Variant
    ReDim arr(1 To UBound(SourceArray), 1 To 1)
    
    Dim i As Long
        For i = 1 To UBound(arr)
            arr(i, 1) = "品名:" & _
                        SourceArray(i, Tb.ListColumns("品名").Index)
        Next
        
        Range("F2").Resize(UBound(arr)) = arr
End Sub

1列しかないのに複数行1列の二次元配列にしたのも、Index関数と同じ理由。
1次元配列を縦に貼り付ける際は、Transpose関数で縦横の入れ替えを行って
いたのだが、この関数もどうやらIndex関数と同じ原因でエラーとなるようだ。

以上はあくまで、「自分ルール」。
どこかで躓いたとき、思い出して頂けたら幸いです。

参考まで。

失敗談の失敗再現を失敗していた話(失敗談)

以前、失敗談としてこんな話を書いた。
Transpose関数には、行列入れ替えの上限があるらしい、という話だ。
infoment.hatenablog.com

ところがよくよく調べてみると、失敗談として紹介したかった内容を、
正しく再現できていないことに気づいた(偶然)。

当時掲載したコードがこちら。

Sub Test()
    Dim arr(1, 1) As Variant
    Dim i As Long
    Dim temp As Variant
    
        On Error Resume Next
        Do
            i = i + 1
            arr(0, 0) = WorksheetFunction.Rept("あ", i)
            temp = WorksheetFunction.Transpose(arr)
        Loop While Err.Number = 0
        
        MsgBox i - 1 & " 個が限界です"
End Sub

なるほど確かに、実行すれば ↓ このようなメッセージがでる。
f:id:Infoment:20210222231444p:plain

ところが実は、このコードはTransposeの限界ではなく、Rept関数の限界を
示していた訳で。
f:id:Infoment:20210222232314p:plain

では、本当に知りたかった限界はどこなのか?ということで、こんな風に
コードを変えて再挑戦。今回文字の長さは、&で継ぎ足してみた。

Sub Test()
    Dim arr(1, 1) As Variant
    Dim i As Long
    Dim temp As Variant
        
        On Error Resume Next
        Do
            i = i + 1
            If i = 32767 Then
                Debug.Print "!"
            End If
            
            arr(0, 0) = arr(0, 0) & "あ"
            temp = WorksheetFunction.Transpose(arr)
            On Error GoTo 0
            
        Loop While Err.Number = 0
        
        MsgBox i - 1 & " 個が限界です"
End Sub

32767個に当たりをつけ、そこまで来たときのデバッグプリントに
ブレークポイントを設けてみた。
f:id:Infoment:20210222232851g:plain

結果、「あ」を32768個並べることはできたが、Transpose関数で
ひっくり返そうとしてエラーが発生。奇しくも(?)Rept関数と
同じ結果になった。

しかし、導出過程が誤りなら、それは正答とは言えませんね。

お詫びと訂正まで。

OR関数についての備忘録

今日はOR関数について、自分用の備忘録(すぐ忘れるので)。
f:id:Infoment:20210215232844p:plain

例えば、指定した県が北陸三県であるか判別したい場合。
ユーザー定義関数でORを用いると、このような表現が可能だ。
とても一般的で、理解し易いと思う。

Function Is北陸_OR(県名 As String) As Boolean
    If 県名 = "福井" Or 県名 = "石川" Or 県名 = "富山" Then
        Is北陸_OR = True
    Else
        Is北陸_OR = False
    End If
End Function

或いは、ORは全部ひっくり返せばNot Andで表すこともできる。
ただし直感的に理解しにくい場合があるため、使い処は選んだ方が良い。

Function Is北陸_NotAnd(県名 As String) As Boolean
    If Not (県名 <> "福井" And 県名 <> "石川" And 県名 <> "富山") Then
        Is北陸_NotAnd = True
    Else
        Is北陸_NotAnd = False
    End If
End Function

またこのような場合は、Select Caseも有効だ。
個人的には、これを最も好んで使っている(分かり易いから)。

Function Is北陸_SelectCase(県名 As String) As Boolean
    Select Case 県名
        Case "福井", "石川", "富山"
            Is北陸_SelectCase = True
        Case Else
            Is北陸_SelectCase = False
    End Select
End Function

もっとも、この程度であれば、ワークシート関数で充分対応できる。
f:id:Infoment:20210215234932p:plain

ところで、同じく個人の意見ではあるが、常々この

OR([@県名]="福井",[@県名]="石川",[@県名]="富山")

の部分で何度も"[@県名]="と書くのが面倒だと思っていた。ところが先日、
このような書き方も可能であることを知った。
f:id:Infoment:20210215235333p:plain

なるほど、これは便利だ!と思ったのも束の間、普段使わないため直ぐに
忘れて探し回ることが何度かあった。年だねぃ、直ぐに忘れる。

探す時間がもったいないので、備忘録としてここに記しておくことにします。

参考まで。

辞書には配列を入れることもできるし、辞書を配列にすることもできる

今日は、辞書(Dictionary)について気づいたお話。
f:id:Infoment:20210211204020p:plain

辞書には、色んなものが入る。例えば、配列も入れられる。
例えば、毎度おなじみ「なんちゃって個人情報」にて。
f:id:Infoment:20210211204137p:plain

名前をキーにして、各行を配列に格納したのち、それをアイテムにしてみる。

Sub Test()
    
    ' 辞書。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' テーブルのデータ範囲を全て、一旦配列に格納。
    Dim arr As Variant
        arr = ActiveSheet.ListObjects(1).DataBodyRange
        
    ' 各行(レコード)について、
    '  キー  :名前
    '  アイテム:レコード単位でスライスされた配列
    ' で辞書を作成する。
    Dim i As Long
        For i = 1 To UBound(arr)
            Dict(arr(i, 2)) = WorksheetFunction.Index(arr, i, 0)
        Next
        
    ' 山上 美紀さんのレコードの7列目(つまり誕生日)を表示。
        MsgBox Dict("山上 美紀")(7)
        
End Sub

果たして結果は、ご覧のとおりだ。
f:id:Infoment:20210211204311p:plain

とここで、ふと思いついた。ひょっとして、辞書を配列にもできる?
早速試してみた。

まず、テーブルのラベル名で列挙体を作成する。

Enum 列名
    enNo = 1
    en名前
    enふりがな
    enアドレス
    en性別
    en年齢
    en誕生日
    en婚姻
    en都道府県
    en携帯
    enキャリア
    enカレーの食べ方
    [_eLast]
End Enum

次いで、ラベル数に応じた辞書の配列を作成し、名前をキーとして
各アイテムをセットする。

Private Function 個人情報(column_index As Long) As Scripting.Dictionary
    Dim Dict(列名.enNo To 列名.enカレーの食べ方) As Scripting.Dictionary
    Dim i As Long
        For i = 列名.enNo To 列名.enカレーの食べ方
            Set Dict(i) = New Scripting.Dictionary
        Next
    Dim j As Long
    Dim arr As Variant
        arr = ActiveSheet.ListObjects(1).DataBodyRange
        For i = 1 To UBound(arr)
            For j = 列名.enNo To 列名.enカレーの食べ方
                Dict(j)(arr(i, 列名.en名前)) = arr(i, j)
            Next
        Next
        
    Set 個人情報 = Dict(column_index)
End Function

すると先程のメッセージボックスは、このようにして表示できる。

Sub test()
    MsgBox 個人情報(列名.en誕生日)("山上 美紀")
End Sub

個人的に、これはこれで面白いと思った。なお、使い処については
いつものように、時と場合とお好みで。

参考まで。