| |
こんなので、CSVから直接Sheet3の表に読み込むと思います
一応、コード中の下記の部分の設定を替えて試して見て下さい
'出力する表の行数
Const clngListCount As Long = 20
'表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
Const clngColPitch As Long = 4
'表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
Const clngRowPitch As Long = 22
'表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
Const clngMaxSet As Long = 5
'出力するCsvの列を出力する順に設定
'例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
'例では、ID=4、名前=0、電話=2と成る
vntPos = Array(4, 0, 2)
'出力先頭セル位置を設定(基準セル位置)
Set rngResult = Worksheets("Sheet3").Cells(2, "A")
この設定例では、データ行が20行の表が、Sheet3のA2をデータの先頭として有る物としています
また、データがこの表からはみ出した場合、右側の表に出力していきます、此れが5枚を越した場合
最初の表の下2行を空けて次の表が書かれて行きます
詰まり、Z型に出力されます
下記もコードを標準モジュールに記述して下さい
Option Explicit
Public Sub DataRead()
'出力する表の行数
Const clngListCount As Long = 20
'表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
Const clngColPitch As Long = 4
'表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
Const clngRowPitch As Long = 22
'表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
Const clngMaxSet As Long = 5
Dim i As Long
Dim lngCount As Long
Dim dfn As Integer
Dim vntFileName As Variant
Dim vntField As Variant
Dim strBuff As String
Dim blnMulti As Boolean
Dim strRec As String
Dim lngRow As Long
Dim rngResult As Range
Dim lngRowOffset As Long
Dim lngColOffset As Long
Dim vntPos As Variant
Dim vntResult As Variant
Dim strProm As String
'出力するCsvの列を出力する順に設定
'例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
'例では、ID=4、名前=0、電話=2と成る
vntPos = Array(4, 0, 2)
'出力先頭セル位置を設定(基準セル位置)
Set rngResult = Worksheets("Sheet3").Cells(2, "A")
'読み込むファイルを取得
If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
'出力行初期値(基準セル位置からの行Offset)
lngRow = 0
'データの読み込み
'ファイルをOpen
dfn = FreeFile
Open vntFileName For Input As dfn
Do Until EOF(dfn)
'１行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'論理レコードをフィールドに分割
vntField = SplitCsv(strRec, ",", , , blnMulti)
'フィールド内で改行が有る場合
If Not blnMulti Then
'出力する配列を確保
ReDim vntResult(0 To UBound(vntPos))
'Csvのフィールド配列を出力配列に転記
On Error Resume Next
For i = 0 To UBound(vntPos)
vntResult(i) = vntField(vntPos(i))
Next i
On Error GoTo 0
'出力行位置を計算
lngRow = lngCount Mod clngListCount
'何処の表に出力するかを計算
lngColOffset = ((lngCount \ clngListCount) _
Mod clngMaxSet) * clngColPitch
lngRowOffset = ((lngCount \ clngListCount) _
\ clngMaxSet) * clngRowPitch
'出力する表を選択
With rngResult.Offset(lngRowOffset, lngColOffset)
'データを出力
.Offset(lngRow).Resize(, _
UBound(vntResult) + 1).Value = vntResult
End With
'処理行数をインクリメント
lngCount = lngCount + 1
strRec = ""
Else
'セル内改行として残す場合
strRec = strRec & vbLf
End If
Loop
Close #dfn
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
'画面更新を再開
Application.ScreenUpdating = True
MsgBox strProm, vbInformation
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
|
|
Hirofumi
- 06/10/26(木) 20:22 -
