splitしてタイトルをつけるマクロ①
2020年04月25日
よく出てくるクソデータとして、
１セルの中に長いメッセージがあって、「○○＝ｘｘｘ」って
毎行にタイトル項目を記載するデータ。
見づらさの極み。
今回は、上記のタイトル項目が全行に記載されているテキストを整理する。
整理対象の列のデータは以下の形式
タイトル
メッセージ。（○○＝XXX)（○×＝YYY)（×○＝ZZZ)
メッセージ。（○○＝XXX)（○×＝BBB)（×○＝XYZ)
メッセージ。（○○＝XXX)（○×＝AAA)（×○＝XYX)
やりたいことは、メッセージと各タイトル、各値にsplitすること。
まず、「)」は不要なので置換。replace関数で消す。
次に「(」でsplit
２列目から最終列については、タイトルと値に分割
これは、「=」でsplit
出力先は、データベースの右側にアペンドする形。
タイトル行の最終列に対してoffsetで指定。
いきなりぶっこむマクロなので、確認メッセージを追加。
if msg( ,vbOKCancel) then の形にすると変数を定義しなくていける。
一応、大量データも想定して、配列に格納してからドカンと出力。
配列を出力するモジュールがあれば、結構簡単。
以下、ソース。
4/26 追記
動かしてみたら、整理対象データの項目数がまちまちで、
タイトル数が行によって違うことが判明。
残念。
不一致の場合は、全体タイトル行を舐めて、一致した列に出力する必要があるなぁ。
お試しの１行処理も、行を選択できるようにしなきゃか。
１セルの中に長いメッセージがあって、「○○＝ｘｘｘ」って
毎行にタイトル項目を記載するデータ。
見づらさの極み。
今回は、上記のタイトル項目が全行に記載されているテキストを整理する。
整理対象の列のデータは以下の形式
タイトル
メッセージ。（○○＝XXX)（○×＝YYY)（×○＝ZZZ)
メッセージ。（○○＝XXX)（○×＝BBB)（×○＝XYZ)
メッセージ。（○○＝XXX)（○×＝AAA)（×○＝XYX)
やりたいことは、メッセージと各タイトル、各値にsplitすること。
まず、「)」は不要なので置換。replace関数で消す。
次に「(」でsplit
２列目から最終列については、タイトルと値に分割
これは、「=」でsplit
出力先は、データベースの右側にアペンドする形。
タイトル行の最終列に対してoffsetで指定。
いきなりぶっこむマクロなので、確認メッセージを追加。
if msg( ,vbOKCancel) then の形にすると変数を定義しなくていける。
一応、大量データも想定して、配列に格納してからドカンと出力。
配列を出力するモジュールがあれば、結構簡単。
以下、ソース。
Option Explicit
Sub RA_Split()
Dim Col As Long: Col = Selection.Column
Dim Egyo As Long: Egyo = Cells(Rows.Count, Col).End(xlUp).Row
Dim Tgyo As Long: Tgyo = Col2Tgyo(Col)
Dim i As Long '配列格納用変数
Dim iMax As Long: iMax = Egyo - Tgyo
If Egyo = 1 Then
MsgBox "データがありません"
Exit Sub
End If
Dim Tcell As Range: Set Tcell = Cells(Tgyo, Columns.Count).End(xlToLeft).Offset(0, 1)
If MsgBox("「" & Cells(Tgyo, Col).Value & "」列の内容を「" & Tcell.Address & "」セルに出力します", vbOKCancel) = vbCancel Then
Exit Sub
End If
Dim tictoc As Double
tictoc = Timer
Dim Gyo As Long: Gyo = Tgyo + 1 '行を定義して、２行目を実行してサイズ検証
Dim buf, mbuf, k As Long '「(」と「=」でsplit用のバッファと配列ループ用変数
buf = Split(Replace(Cells(Gyo, Col).Value, ")", ""), "(") ' 「)」を消して、「(」でsplit
Dim Arr(), tArr() '２配列
ReDim Arr(iMax, UBound(buf)) '2次元出力配列
ReDim tArr(iMax, UBound(buf)) '2次元タイトル配列（エラーチェック用）
Arr(0, 0) = "Text" 'メッセージテキストのタイトルは決め打ち
For k = 1 To UBound(buf)
mbuf = Split(buf(k), "=")
Arr(0, k) = mbuf(0) '先にタイトルを確定させる
Next k
For i = 0 To iMax 'タイトル行から最終行まで
Gyo = i + Tgyo
buf = Split(Replace(Cells(Gyo, Col).Value, ")", ""), "(") ' 「)」を消して、「(」でsplit
For k = 1 To UBound(buf)
mbuf = Split(buf(k), "=")
tArr(i, k) = mbuf(0)
If UBound(mbuf) = 1 Then
Arr(i, k) = mbuf(1) '=が入ってないかも
End If
If tArr(i, k) <> Arr(0, k) Then
Debug.Print "タイトル行エラー i=" & i & "k=" & k
End If
Arr(i, 0) = buf(0)
Next k
Next i
''出力
Call 配列貼り付け_2d(Tcell, Arr)
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
End Sub
Sub 配列貼り付け_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数
'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub
Function Col2Tgyo(Col As Long) As Long
If Cells(1, Col) <> "" Then
Col2Tgyo = 1
Else
Col2Tgyo = Cells(1, Col).End(xlDown).Row
End If
End Function
4/26 追記
動かしてみたら、整理対象データの項目数がまちまちで、
タイトル数が行によって違うことが判明。
残念。
不一致の場合は、全体タイトル行を舐めて、一致した列に出力する必要があるなぁ。
お試しの１行処理も、行を選択できるようにしなきゃか。
PR
Comment