| |
データを見ていないので、上手く行かないかも？
前の質問と同じに、シートに項目別に出力すると言う事で？？
Option Explicit
Public Sub Sample_2()
' シートに読み込まれた文字列から抽出する場合
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntResult As Variant
Dim vntKeys As Variant
Dim lngTop As Long
Dim lngLf As Long
Dim lngColon As Long
Dim strProm As String
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = ActiveSheet.Range("A1")
'結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = ActiveSheet.Range("B1")
'抽出する項目名を列挙
vntKeys = Array("□商品名", "□数量", "□お名前", "□電話", "□住所", "お客様コメント")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'項目名分の要素数を持つ出力用配列を確保
ReDim vntResult(UBound(vntKeys))
'Key列に就いて繰り返し
For i = 1 To lngRows
'1セル分変数に取得
vntData = rngList.Cells(i, 1).Value
'項目名分繰り返し
For j = 0 To UBound(vntKeys)
'項目名の位置を取得
lngTop = InStr(1, vntData, vntKeys(j), vbBinaryCompare)
'項目名が在った場合
If lngTop > 0 Then
'項目名の後ろに在るコロンの位置を取得
lngColon = InStr(lngTop + 1, vntData, "：", vbTextCompare)
'コロンが在ったら
If lngColon > 0 Then
'コロンの後ろのLf(ラインフィード)の位置を取得
lngLf = InStr(lngColon + 1, vntData, vbLf, vbBinaryCompare)
'見つかった、コロンとLfの間の文字列を取得し配列指定位置に格納
vntResult(j) = Mid(vntData, lngColon + 1, lngLf - lngColon - 1)
End If
End If
Next j
'結果を出力
rngResult.Cells(i, 1).Resize(, UBound(vntKeys) + 1).Value = vntResult
'出力用配列を初期化（再確保）
ReDim vntResult(UBound(vntKeys))
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Public Sub Sample_3()
' Csvファイ理から直接抽出する場合
Dim i As Long
Dim lngRows As Long
Dim rngResult As Range
Dim vntResult As Variant
Dim vntKeys As Variant
Dim lngTop As Long
Dim lngLf As Long
Dim lngColon As Long
Dim dfn As Integer
Dim vntFilename As Variant
Dim lngWrite As Long
Dim strBuff As String
Dim strProm As String
'結果出力の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = ActiveSheet.Range("B1")
'抽出する項目名を列挙
vntKeys = Array("□商品名", "□数量", "□お名前", "□電話", "□住所", "お客様コメント")
If Not GetReadFile(vntFilename, ThisWorkbook.Path) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
lngRows = 0
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
'項目名分の要素数を持つ出力用配列を確保
ReDim vntResult(UBound(vntKeys))
'ファイルをOpen
dfn = FreeFile
Open vntFilename For Input As dfn
Do Until EOF(dfn)
'ファイルから1行分取得
Line Input #dfn, strBuff
If strBuff <> "" Then
'項目名分繰り返し
For i = 0 To UBound(vntKeys)
'項目名の位置を取得
lngTop = InStr(1, strBuff, vntKeys(i), vbBinaryCompare)
'項目名が在った場合
If lngTop > 0 Then
'項目名の後ろに在るコロンの位置を取得
lngColon = InStr(lngTop + 1, strBuff, "：", vbTextCompare)
'コロンが在ったら
If lngColon > 0 Then
'コロンの後ろのLf(ラインフィード)の位置を取得
lngLf = InStr(lngColon + 1, strBuff, vbLf, vbBinaryCompare)
'見つかった、コロンとLfの間の文字列を取得し配列指定位置に格納
vntResult(i) = Mid(strBuff, lngColon + 1, lngLf - lngColon - 1)
End If
End If
Next i
'結果を出力
lngWrite = lngWrite + 1
rngResult.Cells(lngWrite, 1).Resize(, UBound(vntKeys) + 1).Value = vntResult
'出力用配列を初期化（再確保）
ReDim vntResult(UBound(vntKeys))
End If
Loop
Close #dfn
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
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
- 10/1/18(月) 19:43 -
