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
クリップボードの内容をテキストファイルに保存するVBScript②
2020年04月27日
前回、クリップボードの文字列を取得して、
日時＋ファイル名指定でメモ帳に保存するVBscriptを作った。
動作確認したところ、環境依存文字が含まれるとうまくいかない。
WEBページの文字列って環境依存系多いのよね。
ブラウザ履歴を取得するマクロを作ったときも苦労したな。。。
で、調べたらいいページ発見。
https://blog.systemjp.net/entry/2013/04/10/191821
CreateTextFileの指定を変えるとUnicodeになるようだ。
修正前：fso.CreateTextFile(fName, true)
修正後：fso.CreateTextFile(fName, true,true)
CreateTextFileメソッドについては、ここがわかりやすい。
https://vbabeginner.net/filesystemobject%E3%81%AEcreatetextfile%E3%83%A1%E3%82%BD%E3%83%83%E3%83%89/
ただし、VBscript自体の文字コードもUnicodeで保存する必要あり！
その他、InputBoxを表示中にコピー操作もあるので、処理順を変更。
以下、ソース。
'ファイル名を生成
dim iText
iText = inputbox("ファイル名を指定")
dim ClipText
ClipText=GetClipboardText()
dim date,fName
date=Replace(now, "/", "")
date=Replace( date , ":" , "" )
date=Replace( date , " " , "_" )
date=left(date , 13)
if iText ="" then
fName ="ClipText_" & date & ".txt"
else
fName ="ClipText_" & date & "(" & iText & ").txt"
end if
'テキストファイルを作って書き込み https://win.just4fun.biz/
dim fso,tso
Set fso = CreateObject("Scripting.FileSystemObject")
Set tso = fso.CreateTextFile(fName, true,true) ' unicode
tso.Write(ClipText)
tso.Close
'クリップボードを取得 'http://osanai.org/47/
Function GetClipboardText()
Dim objHTML
Set objHTML = CreateObject("htmlfile")
GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function
日付のフォルダを作るVBscript
2020年04月27日
なんかの作業をする場合、日付のフォルダを作ることが多い。
日付だけの場合もあれば、アンダーバーで区切って内容を入れることも。
前回、日付のファイルを作ったので、同様にやってみた。
まずは、日付のフォルダを作るところをググる。
https://dev.w.ezic.info/1926.html
こんなもんか。
例によって、InputBoxを使って文字を取得して、
その内容によって分岐。
テキストファイルは上書きでOKだけど、
フォルダはそうもいかないので存在チェック。
https://multiplechoice.hatenablog.com/entry/2017/12/10/195302
ファイルとフォルダ違うけど、fileをFolderに修正して動いた。
処理の流れは、こんな感じ。
まず、文字を入力。
なしなら日付のフォルダ、あれば日付_入力した文字のフォルダ。
個人的な都合で、「)」で始まる文字を入れた場合は、
日付を（）で挟むフォルダ。
以下、ソース。
日付だけの場合もあれば、アンダーバーで区切って内容を入れることも。
前回、日付のファイルを作ったので、同様にやってみた。
まずは、日付のフォルダを作るところをググる。
https://dev.w.ezic.info/1926.html
こんなもんか。
例によって、InputBoxを使って文字を取得して、
その内容によって分岐。
テキストファイルは上書きでOKだけど、
フォルダはそうもいかないので存在チェック。
https://multiplechoice.hatenablog.com/entry/2017/12/10/195302
ファイルとフォルダ違うけど、fileをFolderに修正して動いた。
処理の流れは、こんな感じ。
まず、文字を入力。
なしなら日付のフォルダ、あれば日付_入力した文字のフォルダ。
個人的な都合で、「)」で始まる文字を入れた場合は、
日付を（）で挟むフォルダ。
以下、ソース。
'文字列を取得
dim iText
iText = inputbox("作成するフォルダの内容は？")
'フォルダ名
dim date,DirName
date=Replace(now, "/", "")
date=left(date , 8)
if iText ="" then
DirName =date
elseif left(iText,1)=")" then
DirName = "(" & date & ")_" & mid(iText ,2,len(iText)-1)
else
DirName = date & "_" & iText
end if
' ファイルストリーム・オブジェクト生成
Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FolderExists(DirName) Then
msgbox "すでにフォルダが存在します"
else
' フォルダを生成する
str_path = objFS.CreateFolder(DirName)
end if
クリップボードの内容をテキストファイルに保存するVBScript①
2020年04月26日
LiveMailを使ってて、印刷や保存をするとき、
印刷プレビューを表示して、印刷ボタンを押す。
だけど、Edgeの印刷はUIがいけてないし、LiveMailの印刷プレビューとかモサモサ。
PDF保存に至っては、PDFプリンタ選択してファイル名指定ってもうイヤ。
じゃあもうテキストファイルでいいじゃん！という話。
テキストファイル扱うんだったら,VBscriptでできるんじゃね？と思いつくってみた。
いずれもググってすぐ欲しいソースが出てきた。めっちゃ簡単やん。
処理の流れ
まずは、クリップボードのテキストを取得。
http://osanai.org/47/
次に、テキストの内容をファイルに出力。
https://win.just4fun.biz/?WSH/ファイルを新規に作成しテキストを書き込むサンプルコード#h38cd307
これで十分そうだけど、保存するファイル名変えたいよね。
now関数で現在時刻を文字列で取れるので、Replaceで置換してファイル名に放り込み。
ファイル名を指定するだけで、スクリプトファイルと同じディレクトリに
クリップボードの内容が日付入りのファイル名で保存される。
いい感じだ！！！
以下、ソース。
の前に、やっぱりファイル名とか自由に変えられたほうがいいよね。
InputBoxで文字を入れたら、それがファイル名に使われる仕様も入れてみた。
今度こそソース。
'ファイル名を生成
印刷プレビューを表示して、印刷ボタンを押す。
だけど、Edgeの印刷はUIがいけてないし、LiveMailの印刷プレビューとかモサモサ。
PDF保存に至っては、PDFプリンタ選択してファイル名指定ってもうイヤ。
じゃあもうテキストファイルでいいじゃん！という話。
テキストファイル扱うんだったら,VBscriptでできるんじゃね？と思いつくってみた。
いずれもググってすぐ欲しいソースが出てきた。めっちゃ簡単やん。
処理の流れ
まずは、クリップボードのテキストを取得。
http://osanai.org/47/
次に、テキストの内容をファイルに出力。
https://win.just4fun.biz/?WSH/ファイルを新規に作成しテキストを書き込むサンプルコード#h38cd307
これで十分そうだけど、保存するファイル名変えたいよね。
now関数で現在時刻を文字列で取れるので、Replaceで置換してファイル名に放り込み。
ファイル名を指定するだけで、スクリプトファイルと同じディレクトリに
クリップボードの内容が日付入りのファイル名で保存される。
いい感じだ！！！
以下、ソース。
の前に、やっぱりファイル名とか自由に変えられたほうがいいよね。
InputBoxで文字を入れたら、それがファイル名に使われる仕様も入れてみた。
今度こそソース。
dim ClipText
ClipText=GetClipboardText()
'テキスト取得
dim iText
iText = inputbox("ファイル名を指定")
'ファイル名を生成
dim date,fName
date=Replace(now, "/", "")
date=Replace( date , ":" , "" )
date=Replace( date , " " , "_" )
date=left(date , 13)
if iText ="" then
fName ="ClipText_" & date & ".txt"
else
fName ="ClipText_" & date & "(" & iText & ").txt"
end if
'テキストファイルを作って書き込み https://win.just4fun.biz/
dim fso,tso
Set fso = CreateObject("Scripting.FileSystemObject")
Set tso = fso.CreateTextFile(fName, true)
tso.Write(ClipText)
tso.Close
'クリップボードを取得 'http://osanai.org/47/
Function GetClipboardText()
Dim objHTML
Set objHTML = CreateObject("htmlfile")
GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
End Function
どうやら環境依存文字があるとうまくいかない。てなわけで②に続く。
どうやら環境依存文字があるとうまくいかない。てなわけで②に続く。
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 追記
動かしてみたら、整理対象データの項目数がまちまちで、
タイトル数が行によって違うことが判明。
残念。
不一致の場合は、全体タイトル行を舐めて、一致した列に出力する必要があるなぁ。
お試しの１行処理も、行を選択できるようにしなきゃか。