| |
こんなで善いのかな？
Option Explicit
Public Sub DelimCount()
Dim vntFileName As Variant
Dim lngRow As Long
Dim rngResult As Range
Dim strProm As String
'出力先頭セル位置を設定(基準セル位置)
Set rngResult = ActiveSheet.Cells(1, "A")
'読み込むファイルを取得
If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
'列見出しを出力
rngResult.Resize(, 4).Value = Array("Key", "半角カンマ", "全半角カンマ", "区切りのカンマ")
'出力行初期値(基準セル位置からの行Offset)
lngRow = 1
'データの読み込み
CSVRead vntFileName, rngResult, lngRow
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
'画面更新を再開
Application.ScreenUpdating = True
MsgBox strProm, vbInformation
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByRef rngWrite As Range, _
Optional ByRef lngRow As Long = 1, _
Optional strDelim As String = ",")
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
Dim vntResult As Variant
'出力用配列を確保
ReDim vntResult(3)
'ファイルを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
'Keyを代入
vntResult(0) = vntField(0)
'半角カンマの数を代入
vntResult(1) = CommaCount(strRec, vbBinaryCompare)
'全角+半角カンマの数を代入
vntResult(2) = CommaCount(strRec, vbTextCompare)
'区切り文字としてのカンマ数を代入
vntResult(3) = UBound(vntField)
With rngWrite.Offset(lngRow)
With .Resize(, UBound(vntResult) + 1)
'データを出力
.Value = vntResult
End With
End With
'出力行をインクリメント
lngRow = lngRow + 1
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbLf
End If
Loop
Close #dfn
End Sub
Public 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 CommaCount(strValue As String, _
Optional lngCompare As Long _
= vbBinaryCompare) As Long
Dim i As Long
Dim lngPos As Long
Dim lngCount As Long
lngPos = InStr(1, strValue, ",", lngCompare)
Do Until lngPos = 0
lngCount = lngCount + 1
i = lngPos
lngPos = InStr(i + 1, strValue, ",", lngCompare)
Loop
CommaCount = lngCount
End Function
Public 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/2/9(金) 20:49 -
