| |
チョット違うけど、こんなのも有るよ
CsvDataReadと言うマクロを実行すると「フォーマット.xls」がOpenされ
「ファイルを開く」ダイアログが表示されます
ここで、Csvファイルをを複数選択すると、選択されたファイルが
「フォーマット.xls」にシートが追加され、１シート１ファイルとして、
其処へ読み込まれます
「実行ファイルという名のExcelのブック」のコマンドボタンで「Sub CsvDataRead」を
実行する様にして下さい
また、「フォーマット.xls」の有る場所は、現状のコードでは、
「実行ファイルという名のExcelのブック」と同じフォルダとしていますので
これは実状に合わせて下さい
Option Explicit
Public Sub CsvDataRead()
Dim i As Long
Dim vntFileNames As Variant
Dim lngWriteRow As Long
Dim wksWrite As Worksheet
Dim strPath As String
Dim strSheetName As String
'Csvファイルを読み込むBookをOpen
Workbooks.Open ThisWorkbook.Path _
& "\" & "フォーマット.xls"
'Csvファイルの有るフォルダを指定
strPath = ActiveWorkbook.Path
' strPath = "D:\Data Folder"
'「ファイルを開く」ダイアログを複数選択で表示
If Not GetReadFile(vntFileNames, strPath, True) Then
Exit Sub
End If
' Application.ScreenUpdating = False
'複数選択されたファイルをシートに出力
For i = 1 To UBound(vntFileNames)
'シート名を作成
strSheetName _
= GetFileName(vntFileNames(i))
strSheetName _
= GetSheetName(strSheetName)
'アクティブBookにシートを追加
With ActiveWorkbook.Worksheets
'出力シートを設定
Set wksWrite _
= .Add(After:=Worksheets(.Count))
End With
'シート名を変更
wksWrite.Name = strSheetName
'出力する先頭行を設定
lngWriteRow = 1
'CSVを書き込み
CSVRead vntFileNames(i), _
wksWrite, lngWriteRow, 1
' wksWrite.Columns.AutoFit
Next i
Set wksWrite = Nothing
' Application.ScreenUpdating = True
Beep
MsgBox "処理が完了しました"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
ByVal wksWrite As Worksheet, _
Optional ByRef lngRow As Long = 1, _
Optional ByRef lngCol As Long = 1)
Dim dfn As Integer
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
'空きファイルバファ番号を取得
dfn = FreeFile
'ファイルをInputモードで開く
Open strFileName For Input As dfn
'ファイルエンドまで繰り返し
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'レコードをフィールドに分割
vntField = SplitCsv(strBuff, ",", , , blnMulti)
'物理レコードに改行が有った場合
If blnMulti Then
strRec = strRec & vbLf
Else
'指定シートの指定列、行について
With wksWrite.Cells(lngRow, lngCol)
'結果配列を代入
.Offset.Resize(, UBound(vntField) + 1) = vntField
End With
'書き込み行を更新
lngRow = lngRow + 1
'論理レコードをクリア
strRec = ""
End If
Loop
'ファイルをClose
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 lngDPos As Long
Dim vntData() As Variant
Dim lngStart As Long
Dim i As Long
Dim vntField As String
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)
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 = ""
i = i + 1
Loop Until lngLength < lngStart
SplitCsv = vntData()
End Function
Private Function GetReadFile(vntFileNames As Variant, _
Optional strFilePath As String, _
Optional blnMulti 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, False
End If
vntFileNames _
= Application.GetOpenFilename(strFilter, 1, , , blnMulti)
If Not VarType(vntFileNames) = vbBoolean Then
GetReadFile = True
End If
End Function
Private Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String) As Boolean
Dim strFilter As String
Dim strInitialFile As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt"
'既定値のファイル名を設定
strInitialFile = vntFileName
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'「ファイルを保存」ダイアログを表示
vntFileName _
= Application.GetSaveAsFilename(vntFileName, strFilter, 1)
If vntFileName = False Then
Exit Function
End If
GetWriteFile = True
End Function
Private Function GetSheetName(ByVal strName As String, _
Optional ByVal wkbBook As Workbook) As String
' 同一シート名の存在確認と枝番付加
Dim i As Long
Dim lngPos As Long
Dim lngNumb As Long
Dim lngTmpNumb As Long
Dim strSName As String
If wkbBook Is Nothing Then
Set wkbBook = ThisWorkbook
End If
lngPos = Len(strName) + 1
lngNumb = -1
With wkbBook
For i = 1 To .Worksheets.Count
strSName = .Worksheets(i).Name
If strSName Like strName & "*" Then
Select Case Mid(strSName, lngPos, 1)
Case ""
lngTmpNumb = 0
Case "("
lngTmpNumb _
= InStr(1, strSName, ")", _
vbBinaryCompare)
If lngTmpNumb > 0 Then
lngTmpNumb _
= Val(Mid(strSName, lngPos + 1, _
lngTmpNumb - lngPos - 1))
Else
lngTmpNumb _
= Val(Mid(strSName, lngPos + 1))
End If
Case Else
lngTmpNumb = -1
End Select
If lngNumb < lngTmpNumb Then
lngNumb = lngTmpNumb
End If
End If
Next i
End With
Set wkbBook = Nothing
If lngNumb = -1 Then
GetSheetName = strName
Else
GetSheetName = strName & "(" & (lngNumb + 1) & ")"
End If
End Function
Private Function GetFileName(ByVal strName As String) As String
' ファイル名をPathから分離
Dim i As Long
Dim lngPos As Long
i = 0
lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
Do Until lngPos = 0
i = lngPos
lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
Loop
strName = Mid(strName, i + 1)
i = 1
lngPos = InStr(i, strName, ".", vbBinaryCompare)
Do Until lngPos = 0
i = lngPos
lngPos = InStr(i + 1, strName, ".", vbBinaryCompare)
Loop
GetFileName = Left(strName, i - 1)
End Function
|
|
Hirofumi
- 04/5/25(火) 21:05 -
