条件付き書式の「条件」が数式の場合のカウント
条件付き書式で「条件」が数式の場合、その条件を満たすセルの数をカウントするマクロを作ってみました。しかし、条件を満たすセルの数をカウントするには、こんなもん使うよりも作業セルを用いて判定結果を出しておいて、それをカウントするようにした方が確実です。
結構手抜きで作っているので、「条件」が１つの場合だけしか使えません。しかも、いろいろ不備がある可能性があり、実用向きではありません(汗)。
なお、Call している関数は「数式文字列-A1方式・R1C1方式-変換」に書いてあるものです。
Sub Test1() Dim rngT As Range ' 条件付き書式の設定されているセル範囲 Dim rngA As Range Dim fcA As FormatCondition Dim wkCount As Long Dim wkFA1 As String Dim wkFR1C1 As String Set rngT = Worksheets("Sheet1").Range("B2:J10") rngT.Parent.Select Application.ReferenceStyle = xlA1 For Each rngA In rngT Set fcA = rngA.FormatConditions(1) wkFA1 = fcA.Formula1 Call A1ToR1C1(wkFA1, rngT.Cells(1, 1).Address(False, False), wkFR1C1) Call R1C1ToA1(wkFR1C1, rngA.Address(False, False), wkFA1) If Application.Evaluate(wkFA1) Then wkCount = wkCount + 1 End If Next rngA MsgBox wkCount, vbInformation End Sub
数式文字列-A1方式・R1C1方式-変換
Excelでは、セルの参照形式として、A1方式とR1C1方式があります。
A1方式で記述されている数式をR1C1方式の記述に変更するプロシージャと、その逆をするプロシージャを作ってみました。
実は、「条件付き書式の「条件」が数式の場合のカウント」のために作ったものです。
' # 数式文字列変換(A1→R1C1) # ' argFmlA1 :i 数式文字列(A1) ' argBaseAdls :i 基準セルアドレス ' argFmlR1C1 :o 数式文字列(R1C1) Public Function A1ToR1C1(ByVal argFmlA1 As String _ , ByVal argBaseAdls As String _ , ByRef argFmlR1C1 As String) As Boolean Dim aryD As Variant Dim wkF As String Dim i As Variant Dim V As Variant Dim j As Long Dim wkRowB As Long Dim wkColB As Long Dim wkExPos As Long Dim wkAdlsA As String Dim wkSheetA As String Dim rngA As Range Dim wkRowA As Long Dim wkColA As Long wkRowB = Range(argBaseAdls).Row wkColB = Range(argBaseAdls).Column aryD = Array("=", "<", ">", "(", ")", "+", "-", "*", "/", "^", "&", " ", ":", ",") wkF = argFmlA1 For Each i In aryD wkF = Replace(wkF, i, vbTab & i & vbTab) Next i V = Split(wkF, vbTab) For j = LBound(V) To UBound(V) ' シート参照の場合、シート部分とセル部分に分割する wkExPos = InStrRev(V(j), "!") If wkExPos = 0 Then wkSheetA = "" wkAdlsA = V(j) Else wkSheetA = Left$(V(j), wkExPos) wkAdlsA = Mid$(V(j), wkExPos + 1) End If ' セルかどうか判別する Set rngA = Nothing On Error Resume Next Set rngA = Range(wkAdlsA) On Error GoTo 0 ' セルの場合、R1C1形式に変換する If Not rngA Is Nothing Then wkRowA = rngA.Row wkColA = rngA.Column V(j) = "R[" & (wkRowA - wkRowB) _ & "]C[" & (wkColA - wkColB) & "]" V(j) = wkSheetA & Replace(V(j), "[0]", "") End If Next j argFmlR1C1 = Replace(Join(V, vbTab), vbTab, "") A1ToR1C1 = True End Function
' # 数式文字列変換(R1C1→A1) # ' argFmlR1C1 :i 数式文字列(R1C1) ' argBaseAdls :i 基準セルアドレス ' argFmlA1 :o 数式文字列(A1) Public Function R1C1ToA1(ByVal argFmlR1C1 As String _ , ByVal argBaseAdls As String _ , ByRef argFmlA1 As String) As Boolean Dim aryD As Variant Dim wkF As String Dim i As Variant Dim V As Variant Dim j As Long Dim wkRowB As Long Dim wkColB As Long Dim wkExPos As Long Dim wkAdlsA As String Dim wkSheetA As String Dim wkTxt As String Dim wkAdlsRowFlg As Boolean Dim wkAdlsColFlg As Boolean Dim wkRowA As Long Dim wkColA As Long wkRowB = Range(argBaseAdls).Row wkColB = Range(argBaseAdls).Column aryD = Array("=", "<", ">", "(", ")", "+", "-", "*", "/", "^", "&", " ", ":", ",") wkF = argFmlR1C1 For Each i In aryD wkF = Replace(wkF, i, vbTab & i & vbTab) Next i V = Split(wkF, vbTab) For j = LBound(V) + 2 To UBound(V) - 0 If Right(V(j - 2), 1) = "[" And V(j - 1) = "-" And InStr(1, V(j), "]") > 0 Then V(j) = V(j - 2) & V(j - 1) & V(j) V(j - 2) = "" V(j - 1) = "" End If Next j For j = LBound(V) To UBound(V) ' シート参照の場合、シート部分とセル部分に分割する wkExPos = InStrRev(V(j), "!") If wkExPos = 0 Then wkSheetA = "" wkAdlsA = V(j) Else wkSheetA = Left$(V(j), wkExPos) wkAdlsA = Mid$(V(j), wkExPos + 1) End If ' セルかどうか判別し、行・列の番号を求める wkAdlsRowFlg = False wkAdlsColFlg = False If wkAdlsA Like "R*C*" Then wkTxt = Mid$(wkAdlsA, 2, InStr(1, wkAdlsA, "C") - 2) If wkTxt = "" Then wkAdlsRowFlg = True wkRowA = wkRowB ElseIf IsNumeric(wkTxt) Then wkAdlsRowFlg = True wkRowA = CLng(wkTxt) ElseIf Left(wkTxt, 1) = "[" And Right(wkTxt, 1) = "]" Then wkTxt = Mid(wkTxt, 2, Len(wkTxt) - 2) If IsNumeric(wkTxt) Then wkAdlsRowFlg = True wkRowA = CLng(wkTxt) + wkRowB End If End If wkTxt = Mid$(wkAdlsA, InStr(1, wkAdlsA, "C") + 1) If wkTxt = "" Then wkAdlsColFlg = True wkColA = wkColB ElseIf IsNumeric(wkTxt) Then wkAdlsColFlg = True wkColA = CLng(wkTxt) ElseIf Left(wkTxt, 1) = "[" And Right(wkTxt, 1) = "]" Then wkTxt = Mid(wkTxt, 2, Len(wkTxt) - 2) If IsNumeric(wkTxt) Then wkAdlsColFlg = True wkColA = CLng(wkTxt) + wkColB End If End If End If ' セルの場合、A1形式に変換する If wkAdlsRowFlg And wkAdlsColFlg Then V(j) = wkSheetA & Cells(wkRowA, wkColA).Address(False, False) End If Next j argFmlA1 = Replace(Join(V, vbTab), vbTab, "") R1C1ToA1 = True End Function
両方ともあまり完成度の高くないコードなので、数式次第では期待した結果を返さない場合があります。
例えば、数式内に文字列があり、それがセルアドレスとaryDで使っている区切りで構成される場合などがそうです。
文字列分割プロシージャ(泣き別れ防止)
住所などの長い文字列を印刷する場合、適度な長さで分割して複数行にすることがよくあります。
その場合、単純に文字の長さだけで分割すると、変な位置で切れてしまって見栄えがよくありません。
そういうときのために、適切な位置で切るプロシージャを用意しておくと何かと便利です。
汎用的なので使いまわしがききますし。
なお、スペースで区切りを判定するようにしてあるので、スペースで区切られていないと単純に文字の長さだけで分割します。
' # 文字列分割(泣き別れ防止) # ' argI :i 分割対象文字列 ' argLen :i 分割単位文字数 ' argO :o 分割結果文字列 Private Function DivideText4(ByVal argI As String _ , ByVal argLen As Long _ , ByRef argO As String) As Boolean Dim wkRow(1 To 5) As String Dim wkTextBuf As String Dim wkText1 As String Dim DivPos As Long Dim FindFlg As Boolean Dim I As Long Dim j As Long wkTextBuf = argI wkRow(1) = argI For j = 1 To 4 If Len(wkRow(j)) <= argLen Then Exit For End If ' 区切り位置を探す FindFlg = False For I = argLen + 1 To 1 Step -1 wkText1 = Mid(wkTextBuf, I, 1) If wkText1 = Space(1) Or wkText1 = " " Then DivPos = I FindFlg = True Exit For End If Next I ' 区切り位置で区切る If FindFlg Then wkRow(j) = Mid(wkTextBuf, 1, DivPos - 1) wkRow(j + 1) = Mid(wkTextBuf, DivPos + 1) Else wkRow(j) = Mid(wkTextBuf, 1, argLen) wkRow(j + 1) = Mid(wkTextBuf, argLen + 1) End If ' 次の文字列を用意する wkTextBuf = wkRow(j + 1) Next j If wkRow(5) = "" Then argO = wkRow(1) & vbLf _ & wkRow(2) & vbLf _ & wkRow(3) & vbLf _ & wkRow(4) DivideText4 = True End If End Function
以下は、サンプルテスト用のドライバです。
Sub TEST() Dim I As String Dim O As String Dim Re As Boolean I = "鹿児島県 札幌市 千代田区 嵯峨二尊院門前善光寺山町 大字高津原 １２−３４ シティテラス大井高津原ヒルトップガーデン ７７７号室" Re = DivideText4(I, 25, O) Debug.Print I Debug.Print O Debug.Print "----+----1----+----2----+----3----+----4----+----5" I = "東京都 港区 六本木 １−６−１ 泉ガーデンタワー １８階" Re = DivideText4(I, 25, O) Debug.Print I Debug.Print O Debug.Print "----+----1----+----2----+----3----+----4----+----5" End Sub
セルへの出力で配列を使う場合の注意点
Excelで大量の値を連続したセルに代入したい場合、値を２次元配列に格納しておいて、それを同じサイズのセル範囲のValueプロパティに代入するということはよく行われます。
これは、高速化のテクニックとして非常にポピュラーなものです。
１セルずつ出力しても配列で一気に出力しても処理結果はほとんどの場合は同じですが、常にそうなるとは限りません。
データの長さ次第で、後者に限ってエラーになります。
まずは、同じ処理結果になる場合のサンプルコードです。
Sub TEST() Const cLen As Long = 8203 ' ココ Dim shtA As Worksheet Dim aryX(1 To 1, 1 To 2) Set shtA = Worksheets("Sheet1") shtA.Cells(1, 1).Resize(1, 4).Clear aryX(1, 1) = cLen aryX(1, 2) = String(cLen - 1, "A") & "B" ' # １セルずつ出力 # With shtA.Cells(1, 1) .Value = aryX(1, 1) .Offset(, 1).Value = aryX(1, 2) End With Debug.Print "１セルずつ出力 無事終了" ' # まとめて出力 # shtA.Cells(1, 3).Resize(1, 2).Value = aryX Debug.Print "まとめて出力 無事終了" End Sub
このコードを
Const cLen As Long = 8204 ' ココ
とすると、以下のエラーが出ます。
実行時エラー'1004':
アプリケーション定義またはオブジェクト定義のエラーです。
このエラーは、# まとめて出力 #で起こり、その前の# １セルずつ出力 #は正常に動作します。
つまり、文字列長が8203文字を超える場合には、配列を使って一気に出力することができないということです。
（上記は、Excel2007で試しています。Excel2003以前では長さのリミットはこれよりも短く(911文字)なるようです。）
テキストファイル(UTF-8)の作成
シート上の一定のセル範囲にあるデータを UTF-8(Uni-Code) のテキストデータとして出力するマクロのサンプルです。
ただそれだけです。
' # 参照設定：Microsoft ActiveX Data Objects 2.8 Library Public Sub Main() Const cFilename As String = "TESTOUT.txt" Const cStartRow As Long = 2 Dim EndRow As Long Dim ADOStream As ADODB.Stream Dim shtT As Worksheet Dim i As Long Dim aryItem As Variant Dim OtRec As String Dim FName As String Set shtT = ThisWorkbook.Worksheets("Sheet1") ' B列を基準に最終行番号を取得する EndRow = shtT.Cells(shtT.Rows.Count, 2).End(xlUp).Row FName = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path & "\" & cFilename _ , FileFilter:="テキストファイル (*.txt), *.txt" _ , Title:="出力ファイルの指定") If FName = CStr(False) Then Exit Sub Set ADOStream = New ADODB.Stream ADOStream.Open ADOStream.Charset = "UTF-8" On Error GoTo Error_Rtn For i = cStartRow To EndRow ' B列を基準に３列分のデータを取得する aryItem = shtT.Cells(i, 2).Resize(, 3).Value ' ３列分のデータを１レコードにする OtRec = aryItem(1, 1) & "," & aryItem(1, 2) & "," & aryItem(1, 3) & vbCrLf 'Debug.Print OtRec ADOStream.WriteText OtRec Next i ADOStream.SaveToFile Filename:=FName _ , Options:=adSaveCreateOverWrite ADOStream.Close MsgBox "出力完了", vbInformation Exit Sub Error_Rtn: Debug.Print "Error_Rtn", "i: " & i ADOStream.Close MsgBox "異常終了", vbExclamation End Sub
コピペとセル先頭の ' の削除
Excelは、数値や日付等に変換できる値をセルに入力した場合、自動的に数値や日付等に変換してセルに格納します。
セルの書式設定を「標準」にしたまま、これらの値を文字列として入力する場合には ' を先頭につけて入力します。
セルの書式設定「標準」のままで、セルの値のデータ型を保って、先頭の ' をとるには次の方法でできます。
- 値が入っているセルに対して、「コピー」する
- 別のセルに対して、「形式を選択して貼り付け」で「数式」or「値」で貼り付ける
ここでポイントなのは、貼り付ける際に別のセルを選択することです。
コピーしたセルと同じセルに貼り付けると、先頭の ' は残ってしまいます。
Excel側の内部処理で不要な貼り付けはスキップするようになっているのかもしれませんね。
（上記は、Excel2007 で試しています。）
ファイルが破損したと言われてもダメもとで…
Excelは、Ver.12 − Excel2007からファイル形式も変わって破損しにくくなったらしいです。
ブックの共有機能を使わなければ、以前からファイルの破損に遭遇することが少なかったのであまり実感はありませんが…。
Ver.12からシートあたりの行数も列数も格段に増えたので、非常に重宝してます。
しかし、環境に依存するのかもしれませんが、１シートに大量のデータを格納したまま保存すると、そのブックを開く時にファイルが破損した旨のメッセージが出ることがあるようです。
なお、シートの中はデータのみで数式やシェイプ等は一切なし、マクロもなし、ファイル形式は XLSB です。
（必ず再現する条件があるわけではないのですが、ここ半年くらいで２回遭遇しています。）
ここでブックを開く時にエラーが出た場合、どうも本当はファイルは壊れていないにも関わらずエラーだけが出ているということがあるようです。
この場合、ブックを開くのをキャンセルし、Windowsを一旦ログオフします。
そして、改めて、Windowsにログインして、ブックを開くと、今度はすんなりと開けることがあります。
勿論、常にこれでうまく行くという保証はまったくありませんが、ダメもとで試す価値は多いにあります。
