| |
はじめまして、ＧＯＮです。
履歴をみてＶＢＡを勉強しています。
ＣＳＶデータの扱いで、ご質問です。
【CSVファイルの例】
"A01","11","ABC","AAAAA","A01 A02 A03","ABCDE","1","1000"
"A02","21","ABC","AA","A01 A02","ABCDE","1","2000"
"A03","31","ABC","AAAAA","","ABCDE","1","3000"
"A04","41","ABC","AAAAA","A01","ABCDE","1","4000"
"A05","51","ABC","AAAAA","A01 A03","ABCDE","1","5000"
【このソースの結果】
A B C D E F G H
1 A01 11 ABC AAAAA A01 ABCDE 1 1000
A02
A03
2 A02 21 ABC AA A01 ABCDE 1 1000
A02
3 A03 31 ABC AAAAA ABCDE 1 1000
4 A04 41 ABC AAAAA A01 ABCDE 1 1000
5 A05 51 ABC AAAAA A01 ABCDE 1 1000
A03
Option Explicit
Public Sub DataRead()
Dim i As Long
Dim vntFileName As Variant
Dim lngRow As Long
Dim strPath As String
Dim rngResult As Range
Dim strProm As String
Dim blnStatusBar As Boolean
Dim objFso As Object
'指定形式のファイル名を取得
strPath = ThisWorkbook.Path
If Not GetReadFile(vntFileName, strPath) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'◆出力先頭セル位置を設定(基準セル位置)
Set rngResult = ActiveSheet.Cells(1, "A")
With Application
'現状のステータスバーの状態を保存
blnStatusBar = .DisplayStatusBar
'ステータスバーを表示
.DisplayStatusBar = True
'画面更新を停止
.ScreenUpdating = False
End With
'データの読み込み
CSVRead vntFileName, rngResult, lngRow, 2
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
With Application
'画面更新を再開
.ScreenUpdating = True
'ステータス バーの文字列を既定値に戻す
.StatusBar = False
'ステータス バーの設定を元に戻す
.DisplayStatusBar = blnStatusBar
End With
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByRef rngWrite As Range, _
Optional ByRef lngRow As Long = 1, _
Optional ByVal lngStart As Long = 1, _
Optional strDelim As String = ",")
' strFileName：Csvのファイル名
' rngWrite：出力基準位置、
' lngRow：出力行位置
' lngStart：Csv読み込み開始行
Dim i As Long
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
'ファイルをOpen
dfn = FreeFile
Open strFileName For Input As dfn
Do Until EOF(dfn)
'１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'論理レコードをフィールドに分割
vntField = SplitCsv(strRec, strDelim, , , blnMulti)
'フィールド内で改行が有る場合
If Not blnMulti Then
'読み込み行数のカウントをとる
i = i + 1
If i >= lngStart Then
With rngWrite.Offset(lngRow)
'出力範囲を文字列に設定
' .Offset(, 1).Resize(, 2).NumberFormat = "@"
'5列目の半角スペースをLfに置き換える
On Error Resume Next
vntField(4) = Replace(vntField(4), " ", vbLf, , , vbBinaryCompare)
On Error GoTo 0
'データを出力
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'出力行をインクリメント
lngRow = lngRow + 1
End If
Application.StatusBar = "読み込み中です．．．．" & i & " レコード目"
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbLf
End If
Loop
Close #dfn
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
Dim i As Long
Dim lngDPos As Long
Dim vntData() As Variant
Dim lngStart 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)
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
というコード、ＣＳＶデータの項目毎に列を指定したい場合は
どのようになりますか？
１項目->A列、２項目->D列、３項目->C列 とか。
本見て調べてるんですが、よくわかりませんので教えてください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
