| |
もう見て居ないかな？
データが、この様なデータなのかな？
りんご￥果物￥12,123,◎◎◎◎,#####
キャベツ￥野菜￥6,456,▲▲▲▲,$$$$$
トマト￥野菜￥9,789,◇◇◇◇,&&&&
何処に、どんな風に出力すか不明なので、
Sheet1にCsvとしての出力
Sheet2に"￥"の区切りの出力をしています
Option Explicit
Public Sub TextRead()
Dim i As Long
Dim dfn As Integer
Dim vntFileName As Variant
Dim strBuff As String
Dim lngRow As Long
Dim rngResult As Range
Dim rngSubResult As Range
Dim vntField As Variant
Dim vntSubField As Variant
Dim strProm As String
'Openするファイルを選択
If Not GetReadFile(vntFileName, ThisWorkbook.Path, False) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'出力する、場所を指定
Set rngResult = Worksheets("Sheet1").Cells(1, "A")
Set rngSubResult = Worksheets("Sheet2").Cells(1, "A")
'ファイルをOpen
dfn = FreeFile
Open vntFileName For Input As dfn
'ファイルエンドまで繰り返し
Do Until EOF(dfn)
'ファイルより1行、変数に読み込み
Line Input #dfn, strBuff
'カンマ区切りデータとして、カンマで分割
vntField = SplitCsv(strBuff, ",")
'Sheet1に出力
With rngResult.Offset(lngRow)
.Resize(, UBound(vntField) + 1).Value = vntField
End With
'"￥"区切り賭して、第0フィールドを分割
'実際に分割するフィールドを指定して下さい
'この場合、フィールドは0から始まります
vntSubField = SplitCsv(vntField(0), "￥")
'Sheet2にサブフィールドを出力
With rngSubResult.Offset(lngRow)
.Resize(, UBound(vntSubField) + 1).Value = vntSubField
End With
'書き込み行を更新
lngRow = lngRow + 1
Loop
'ファイルをClose
Close #dfn
Set rngResult = Nothing
Set rngSubResult = Nothing
strProm = "処理が完了しました"
Wayout:
Beep
MsgBox strProm
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, 2, , , blnMultiSel)
If VarType(vntFileNames) = vbBoolean Then
Exit Function
End If
GetReadFile = True
End Function
|
|
Hirofumi
- 05/7/14(木) 20:11 -
