配列からの値貼り付けに関する覚書 ③ ところどころに数式を含むテーブルに、レコードを丸ごとベタッと貼り付けたい
先日、四苦八苦した体験談からのご紹介。
例えば、こんなテーブルがあるとする。
このテーブル、実は年齢の列だけ数式がセットされている。
このような条件のもと、レコードを追加したい。
例えば、この追加レコードを配列に格納して、テーブルに
ベタっと追加したらどうなるか。
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
結果は、こんな感じ。貼り付けたレコードのうち、一つ目だけ
空白であることが律儀に守られている。
ならば、一行目だけ数式を無理矢理セットしたらどうかと考えた。
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
結果、今度はちゃんと数式がセットされた。
数式を取得してセットする手間はあるが、ベタっと貼り付けられるので
なかなか便利だと思った。実際この方法を採用するかどうかは、いつも
のごとく、時と場合と皆様のお好みで。
参考まで。
複数あるExcelファイルを開いて列幅調整
先日、このような困りごとをお見掛けした。
挑戦してみた。
まず、いつもの「なんちゃって個人情報」から、対象となるファイルっぽい
ものを作成してみた。
中身は、こんな感じだ。
今回は、こんな作戦で行ってみよう。
まず、サブプロシージャは二つ作成する。
- ファイル内の列幅調整用。
- 複数ファイルに対する処理ループ用。
列幅調整については、セル内で折り返されている場合を考慮して、
一旦びよーんと伸ばしてから自動調整してみよう。
まず、繰り返し処理用サブプロシージャがこちら。
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
次に、開かれたファイルの列幅を調整する。ただし、以下を前提とする。
- 各ファイル内の対象シートは一つのみ。
- 調整後のファイルは、別名保存する。
こんな感じだ。
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
実行してみると、各ファイルの編集後ファイルが作成されている。
中身の調整も、上手く行ったようだ。
なお、上記を実際に使用する場合は、編集後と同じ名前のファイル名が
既に存在する場合の処理も必要かもしれません。
参考まで。
配列からの値貼り付けに関する覚書 ② 値と数式の混在は成立しない場合がある(失敗談)
先日体験した失敗談からのご紹介。
例えば、こんなテーブルでのお話。
納期は基本的に、発注日の14日後だ。
ところが、このテーブルの使用者から、こんな要望が寄せられた。
- 果物によっては、納期が変わる場合があって、納期のセルを上書きしたい。
- 上書きの条件は複数様々あり、定まっていない。
- 手入力用の列は設けたくない。
列の内容が数式と手書きで混在するなどやりたくなかったが、要望だから
仕方がない。とここで、閃いた。例えば、こんな方法はどうだろう?
- 納期列に値を張り付けるための配列を準備する。
- もともと設定されていた数式を取得する。
- 各行をループし、上書き条件を満たす場合は値を、
それ以外の場合は数式をセットする。 - 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
さて、実行した結果は・・・何も変わらなかった。どうして?
貼り付け直前の配列の中身を見ると、「みかん」はちゃんと納期の
1週間後になっている。
その後の確認で、「みかん」を「りんご」に、つまり配列の先頭が数式でなく
した場合は、意図した結果になることがわかった。
以上のことから、次のようなルールがあると推測される。
- 配列の先頭が数式であって、且つ貼り付け先がテーブルである場合、
以降の行の値が何であっても、その列は全て先頭の式で満たされる。 - 配列の先頭が値である場合、その列は数式と値が混在しうる。
良い方法を見つけたと思ったのだが・・・失敗です。
参考まで。
配列からの値貼り付けに関する覚書 ① Transpose関数とIndex関数は極力使用しない
ここ一週間ほど、(私にとっての)大規模マクロを作成していて、泥沼に
はまっている(絶賛継続中)。
そこから抜け出そうとして得た教訓を一つ二つ、覚書として残しておこう。
例えば、こんなテーブル。
これについて「品名列をF2~F4に転記したい」とする。その際、各品名の頭に
「品名:」を追加したい。↓ 完成形は、こんな感じだ。
今までは、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
なるほど確かに、実行すれば ↓ このようなメッセージがでる。
ところが実は、このコードはTransposeの限界ではなく、Rept関数の限界を
示していた訳で。
では、本当に知りたかった限界はどこなのか?ということで、こんな風に
コードを変えて再挑戦。今回文字の長さは、&で継ぎ足してみた。
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個に当たりをつけ、そこまで来たときのデバッグプリントに
ブレークポイントを設けてみた。
結果、「あ」を32768個並べることはできたが、Transpose関数で
ひっくり返そうとしてエラーが発生。奇しくも(?)Rept関数と
同じ結果になった。
しかし、導出過程が誤りなら、それは正答とは言えませんね。
お詫びと訂正まで。
OR関数についての備忘録
今日はOR関数について、自分用の備忘録(すぐ忘れるので)。
例えば、指定した県が北陸三県であるか判別したい場合。
ユーザー定義関数で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
もっとも、この程度であれば、ワークシート関数で充分対応できる。
ところで、同じく個人の意見ではあるが、常々この
OR([@県名]="福井",[@県名]="石川",[@県名]="富山")
の部分で何度も"[@県名]="と書くのが面倒だと思っていた。ところが先日、
このような書き方も可能であることを知った。
なるほど、これは便利だ!と思ったのも束の間、普段使わないため直ぐに
忘れて探し回ることが何度かあった。年だねぃ、直ぐに忘れる。
探す時間がもったいないので、備忘録としてここに記しておくことにします。
参考まで。
辞書には配列を入れることもできるし、辞書を配列にすることもできる
今日は、辞書(Dictionary)について気づいたお話。
辞書には、色んなものが入る。例えば、配列も入れられる。
例えば、毎度おなじみ「なんちゃって個人情報」にて。
名前をキーにして、各行を配列に格納したのち、それをアイテムにしてみる。
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
果たして結果は、ご覧のとおりだ。
とここで、ふと思いついた。ひょっとして、辞書を配列にもできる?
早速試してみた。
まず、テーブルのラベル名で列挙体を作成する。
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
個人的に、これはこれで面白いと思った。なお、使い処については
いつものように、時と場合とお好みで。
参考まで。