ファイルのフルパス取得方法（小ネタ）
2020年05月10日
VBAでソースを書くとき、原則ファイルを指定する関数を用意して
ファイル選択する仕様で作るけど、デバッグ作業ではわずらわしくなってくる。
今回は、個別ファイル指定用のフルパスの簡単な取得方法について。
フォルダパスとファイル名を両方コピーして、
引用符で挟んでという作業はもう不要です！
ファイル選択する仕様で作るけど、デバッグ作業ではわずらわしくなってくる。
今回は、個別ファイル指定用のフルパスの簡単な取得方法について。
フォルダパスとファイル名を両方コピーして、
引用符で挟んでという作業はもう不要です！
PR
worksheetfunctionの弊害 配列をエクセルシートに転記するマクロ
2020年05月09日
VBAで、１次元配列をエクセルに転記するときに、
配列を転置しないとうまく貼れない。
ネットで拾った以下のソースを使っていたんだけど、
配列の要素数が多いとうまく動作しないことが判明。
配列を転置しないとうまく貼れない。
ネットで拾った以下のソースを使っていたんだけど、
配列の要素数が多いとうまく動作しないことが判明。
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
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 追記
動かしてみたら、整理対象データの項目数がまちまちで、
タイトル数が行によって違うことが判明。
残念。
不一致の場合は、全体タイトル行を舐めて、一致した列に出力する必要があるなぁ。
お試しの１行処理も、行を選択できるようにしなきゃか。
ログデータの圧縮
2020年03月21日
今回はめっちゃ個人的な内容。
ログデータがでかいから必要な情報だけ取り出したい。
ログには、処理を開始したファイル名と
処理内容がつらつらと書かれているけど、
どのファイルにどんだけ時間がかかったかと
特定のキーワードの処理の番号をとりたい。
高速化のため、時間の範囲を絞る機能も盛り込んでどうやろか。。。
以下、ソース。やっぱDic配列便利だわぁ。
ログデータがでかいから必要な情報だけ取り出したい。
ログには、処理を開始したファイル名と
処理内容がつらつらと書かれているけど、
どのファイルにどんだけ時間がかかったかと
特定のキーワードの処理の番号をとりたい。
高速化のため、時間の範囲を絞る機能も盛り込んでどうやろか。。。
以下、ソース。やっぱDic配列便利だわぁ。
Option Explicit
Sub test()
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
Call LogNを解析(Dic, ファイル名取得())
' Call LogNを解析(Dic, "D:\Dropbox\VBA\WRN解析\20200320_1.log")
Dim Items: Items = Dic.Items
Dim i As Long, j As Long, Vbuf
Dim Arr() As String
ReDim Arr(Dic.Count, 6)
For i = 0 To UBound(Items)
Vbuf = Split(Items(i), "‡")
For j = 0 To UBound(Vbuf)
Arr(i, j) = Vbuf(j)
Next j
Next i
Range("A1").Resize(Dic.Count, 6) = Arr ''1回だけ代入
End Sub
Sub LogNを解析(ByRef Dic, ファイル名 As String, Optional sTxt As String = "", Optional eTxt As String = "‡‡†‡‡")
Dim i As Long, t As String
Dim fCnt As Long, Fname As String
Dim idCnt As Long, ID1 As String, IDN As String 'HAISIN_LIST.IDの数と最初と最後
Dim T1 As String, TN As String
Dim buf As String, Flag
Dic.Add "title", "№" & "‡" & "日時" & "‡" & "Fname" & "‡" & "idCnt" & "‡" & "ID1" & "‡" & "IDN"
Open ファイル名 For Input As #1
Do Until EOF(1)
Line Input #1, buf
If buf Like "*" & sTxt & "*" And Flag = 0 Then
Flag = 1 '書き込み開始
ElseIf buf Like "*" & eTxt & "*" And Flag = 1 Then
'Flag = 0 '書き込み終了
Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
Exit Sub
End If
If Flag = 1 Then '書き込み中
' Debug.Print Buf
If buf Like "*WRN*.txt*" Then '条件はもっと細かくする必要あるかも
If t <> "" Then 'tがあるなら格納できる
Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
idCnt = 0: ID1 = "": IDN = "" '格納したら初期化
End If
'次のファイルに行くのでDic出力までやる
fCnt = fCnt + 1 'ファイル№ = Dicキー
t = Mid(buf, 25, 19)
Fname = WRNファイル名取得(buf)
ElseIf buf Like "*HAISIN_LIST.ID*" Then
idCnt = idCnt + 1
If idCnt = 1 Then ID1 = 配信リストID取得(buf)
IDN = 配信リストID取得(buf)
Else
'何もしない
End If
End If ' If Flag = 1 Then '書き込み中
Loop
Close #1
If fCnt > 1 Then Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
End Sub
Sub LogNを解析b(ByRef Dic, ファイル名 As String, Optional sTxt As String = "", Optional eTxt As String = "‡‡†‡‡")
Dim i As Long, t As String
Dim fCnt As Long, Fname As String
Dim idCnt As Long, ID1 As String, IDN As String 'HAISIN_LIST.IDの数と最初と最後
Dim T1 As String, TN As String
Dim buf As String, Flag
Dic.Add "title", "№" & "‡" & "日時" & "‡" & "Fname" & "‡" & "idCnt" & "‡" & "ID1" & "‡" & "IDN"
Open ファイル名 For Binary As #1
Do Until EOF(1)
Line Input #1, buf
If buf Like "*" & sTxt & "*" And Flag = 0 Then
Flag = 1 '書き込み開始
ElseIf buf Like "*" & eTxt & "*" And Flag = 1 Then
'Flag = 0 '書き込み終了
Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
Exit Sub
End If
If Flag = 1 Then '書き込み中
' Debug.Print Buf
If buf Like "*WRN*.txt*" Then '条件はもっと細かくする必要あるかも
If t <> "" Then 'tがあるなら格納できる
Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
idCnt = 0: ID1 = "": IDN = "" '格納したら初期化
End If
'次のファイルに行くのでDic出力までやる
fCnt = fCnt + 1 'ファイル№ = Dicキー
t = Mid(buf, 25, 19)
Fname = WRNファイル名取得(buf)
ElseIf buf Like "*HAISIN_LIST.ID*" Then
idCnt = idCnt + 1
If idCnt = 1 Then ID1 = 配信リストID取得(buf)
IDN = 配信リストID取得(buf)
Else
'何もしない
End If
End If ' If Flag = 1 Then '書き込み中
Loop
Close #1
If fCnt > 1 Then Dic.Add fCnt, fCnt & "‡" & t & "‡" & Fname & "‡" & idCnt & "‡" & ID1 & "‡" & IDN
End Sub
Function WRNファイル名取得(TextLine As String)
Const Ln = 9
Const keyText = ".txt"
Dim pos As Long
pos = InStr(TextLine, keyText)
If pos < Ln Then
WRNファイル名取得 = ""
Else
WRNファイル名取得 = Mid(TextLine, pos - Ln, Ln + Len(keyText))
End If
End Function
Function 配信リストID取得(TextLine As String)
Const Ln = 9
Const keyText = "HAISIN_LIST.ID = "
Dim pos As Long
pos = InStr(TextLine, keyText)
If pos < Ln Then
配信リストID取得 = ""
Else
配信リストID取得 = Mid(TextLine, pos + Len(keyText), Ln)
End If
End Function
Function ファイル名取得(Optional デフォルト As String = "") 'with ユーザー名取得
If デフォルト = "" Then
デフォルト = "C:\Users\" & ユーザー名取得() & "\Desktop"
End If
Dim i As Long
'’https://excel-ubara.com/excelvba1/EXCELVBA376.html
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FulName As String
With Application.FileDialog(msoFileDialogFilePicker)
'.InitialFileName = デフォルト
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "すべてのファイル", "*.*"
.Title = "ファイルの選択"
If .Show = True Then
FulName = .SelectedItems(1)
Else
MsgBox "キャンセルしました"
End If
End With
Set FSO = Nothing
ファイル名取得 = FulName
End Function
Private Function ユーザー名取得()
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
ユーザー名取得 = WshNetworkObject.UserName
Set WshNetworkObject = Nothing
End Function