| |
多分こんなで、同じ様な事をやると思いますが？
ただし、CsvはSheetに展開をしません、直接ListBoxに代入されます
尚、TextBox1に設定される値には、Like演算のでワイルドカード(?、*)が使用出来ます
以下をUserFormのコードモジュールに全て記述して下さい
Option Explicit
'探索を行う、ListBoxに表示する列数(CSV先頭から7列)
Private Const clngColumns As Long = 7
'読み込むTextFile名
Private vntFileName As Variant
Private Sub CommandButton1_Click()
Dim i As Long
Dim j As Long
Dim dfn As Integer
Dim strBuff As String
Dim strRec As String
Dim blnMulti As Boolean
Dim vntField As Variant
Dim vntKey As Variant
'TextBox1に値が設定されて居なければ
If TextBox1.Text = "" Then
Beep
Exit Sub
Else
'TextBox1の値をKey文字とする
vntKey = Trim(TextBox1.Text)
End If
'ListBoxをクリア
ListBox1.Clear
'CsvファイルをOpen
dfn = FreeFile
Open vntFileName For Input As dfn
Do Until EOF(dfn)
'１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'論理レコードをフィールドに分割
vntField = SplitCsv(strRec, ",", , , blnMulti)
'フィールド内で改行が無い場合
If Not blnMulti Then
'Csv先頭から7列の中にKey文字が含まれるか検査
For i = 0 To clngColumns - 1
'含まれている場合
If vntField(i) Like vntKey Then
Exit For
End If
Next i
'レコードにKey文字が有った場合
If i <= clngColumns - 1 Then
'ListBox1に項目を追加
With ListBox1
.AddItem vntField(0)
For j = 1 To clngColumns - 1
.List(.ListCount - 1, j) = vntField(j)
Next j
End With
End If
strRec = ""
End If
Loop
Close #dfn
End Sub
Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 7
End Sub
Private Sub UserForm_Activate()
'読み込むファイル名を設定
vntFileName = "db"
'ファイルを開くダイアログを表示
If Not GetReadFile(vntFileName, ThisWorkbook.Path, False) Then
Unload Me
MsgBox "マクロがキャンセルされました", vbInformation
End If
End Sub
Private Function SplitCsv(ByVal strLine As String, _
Optional strDelimiter As String = ",", _
Optional strQuote As String = """", _
Optional strRet As String = vbCrLf, _
Optional blnMulti As Boolean) As Variant
' strLine :分割元と成る文字列
' strDelimiter :区切り文字
' SplitCsv :戻り値、切り出された文字配列
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As Variant
Dim lngLength As Long
i = 0
lngStart = 1
lngLength = Len(strLine)
blnMulti = False
Do
ReDim Preserve vntData(i)
If Mid$(strLine, lngStart, 1) <> strQuote Then
lngDPos = InStr(lngStart, strLine, _
strDelimiter, vbBinaryCompare)
If lngDPos > 0 Then
vntField = Mid$(strLine, lngStart, _
lngDPos - lngStart)
If lngDPos = lngLength Then
ReDim Preserve vntData(i + 1)
End If
lngStart = lngDPos + 1
Else
vntField = Mid$(strLine, lngStart)
lngStart = lngLength + 1
End If
Else
lngStart = lngStart + 1
Do
lngDPos = InStr(lngStart, strLine, _
strQuote, vbBinaryCompare)
If lngDPos > 0 Then
vntField = vntField & Mid$(strLine, _
lngStart, lngDPos - lngStart)
lngStart = lngDPos + 1
Select Case Mid$(strLine, lngStart, 1)
Case ""
Exit Do
Case strDelimiter
lngStart = lngStart + 1
Exit Do
Case strQuote
lngStart = lngStart + 1
vntField = vntField & strQuote
End Select
Else
blnMulti = True
vntField = Mid$(strLine, lngStart) & strRet
lngStart = lngLength + 1
Exit Do
End If
Loop
End If
vntData(i) = vntField
vntField = Empty
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMultiSel As Boolean _
= False) As Boolean
Dim strFilter As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt," _
& "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
& "全て (*.*),*.*"
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'もし、ディフォルトのファイル名が有る場合
If vntFileNames <> "" Then
SendKeys vntFileNames & "{TAB}", False
End If
'「ファイルを開く」ダイアログを表示
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 07/1/21(日) 18:16 -
