splitしてタイトルをつけるマクロ②
2020年04月29日
前回作ったマクロが、うまく動作しなかったので修正版。
データ項目が同じとは限らないなんて。。。
開発着手したら工数かかるからこういうのは事前につぶしておきたいですな。
タイトル行が一致しない場合は、全部のタイトル行を舐めて
一致した列にデータを出力する仕様を考えた。
Loopを組んで、一致したセルを探すならいっそのことDic配列でよくね？
で、組んでみたらエラー検出用のタイトルアレーも不要に。
まずInputBoxで行を指定。その行のタイトル列を基準にする。
チェックしている行にタイトル文字列があれば＝以降のデータをその列に格納。
なければエラー出力。
以下、ソース。
データ項目が同じとは限らないなんて。。。
開発着手したら工数かかるからこういうのは事前につぶしておきたいですな。
タイトル行が一致しない場合は、全部のタイトル行を舐めて
一致した列にデータを出力する仕様を考えた。
Loopを組んで、一致したセルを探すならいっそのことDic配列でよくね？
で、組んでみたらエラー検出用のタイトルアレーも不要に。
まずInputBoxで行を指定。その行のタイトル列を基準にする。
チェックしている行にタイトル文字列があれば＝以降のデータをその列に格納。
なければエラー出力。
以下、ソース。
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 TargetGyo '★
TargetGyo = InputBox("「" & Cells(Tgyo, Col).Value & "」列の内容を「" & Tcell.Address & "」セルに出力します。一般行を指定してください。")
If TargetGyo = "" Then Exit Sub
If TargetGyo < Tgyo + 1 Then Exit Sub
If TargetGyo > Egyo Then Exit Sub '文字列もここに入る
Dim tictoc As Double
tictoc = Timer
Dim Gyo As Long: Gyo = TargetGyo 'タイトル列数が行によって違うので指定を可変に
' Dim Gyo As Long: Gyo = Tgyo + 1 '行を定義して、２行目を実行してサイズ検証
Dim buf, mbuf, k As Long '「(」と「=」でsplit用のバッファと配列ループ用変数
buf = Split(Replace(Cells(Gyo, Col).Value, ")", ""), "(") ' 「)」を消して、「(」でsplit
Dim Arr() '２配列
ReDim Arr(iMax, UBound(buf)) '2次元出力配列
Arr(0, 0) = "Text" 'メッセージテキストのタイトルは決め打ち
Dim t As Long, tDic 'ループ変数とタイトルDic配列
Set tDic = CreateObject("scripting.dictionary") 'これを宣言しないと使えない★
For k = 1 To UBound(buf)
mbuf = Split(buf(k), "=")
Arr(0, k) = mbuf(0) '先にタイトルを確定させる
tDic.Add mbuf(0), k 'タイトルLookup用にDicを作っておく ★
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), "=")
If Not tDic.exists(mbuf(0)) Then
Debug.Print "タイトル行エラー i=" & i & "、k=" & k & "、タイトル=" & mbuf(0)
Else
t = tDic(mbuf(0))
Arr(i, t) = mbuf(1)
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
PR
Comment