Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7535 / 13644 ツリー ←次へ | 前へ→

【38407】複数のCSVファイルを一つのブックに maki 06/6/2(金) 8:08 発言[未読]
【38408】Re:複数のCSVファイルを一つのブックに かみちゃん 06/6/2(金) 8:19 発言[未読]
【38409】Re:複数のCSVファイルを一つのブックに かみちゃん 06/6/2(金) 8:23 発言[未読]
【38445】Re:複数のCSVファイルを一つのブックに maki 06/6/3(土) 8:27 質問[未読]
【38451】Re:複数のCSVファイルを一つのブックに かみちゃん 06/6/3(土) 10:21 発言[未読]
【38455】Re:複数のCSVファイルを一つのブックに かみちゃん 06/6/3(土) 11:14 回答[未読]
【38410】Re:複数のCSVファイルを一つのブックに maki 06/6/2(金) 8:29 回答[未読]
【38453】Re:複数のCSVファイルを一つのブックに Hirofumi 06/6/3(土) 10:40 回答[未読]
【38458】Re:複数のCSVファイルを一つのブックに かみちゃん 06/6/3(土) 12:03 発言[未読]
【38461】Re:複数のCSVファイルを一つのブックに Hirofumi 06/6/3(土) 14:23 発言[未読]
【38466】Re:複数のCSVファイルを一つのブックに Kein 06/6/3(土) 15:53 回答[未読]
【38467】Re:複数のCSVファイルを一つのブックに Kein 06/6/3(土) 15:56 発言[未読]
【38493】Re:複数のCSVファイルを一つのブックに maki 06/6/5(月) 0:19 お礼[未読]

【38407】複数のCSVファイルを一つのブックに
発言  maki  - 06/6/2(金) 8:08 -

引用なし
パスワード
   デスクトップに CSVフォルダと
言う名前のフォルダがありまして、その中に
10001csv 〜10010csvの10個のファイルが格納されています。
そのファイルのデータを1つのブックに表示させたいのですが
どのようなマクロになるのでしょうか。ご回答のほど
宜しくお願い致します。なおCSVファイルは10011csv 10012csv・・・
と増える可能性大なのでできればCSVフォルダ内のすべての
ファイルを読み込む方法が知りたいのですが・・・。

【38408】Re:複数のCSVファイルを一つのブックに
発言  かみちゃん  - 06/6/2(金) 8:19 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>そのファイルのデータを1つのブックに表示させたい

1つのCSVファイルをブックに表示させることはできますか?
一般操作でできると思いますので、この部分は「マクロの記録」でできるような気がします。

1つのブックであって、1つのシートではないのですか?
別々のシートでいいのですか?

CSVファイルのフォーマットは、すべて一緒なのですか?

1つのシートに追加していく場合、すべてのCSVファイルの総レコード数が65536を超えるとどうするのですか?

など、いろいろと疑問が出てきます。

なお、特定のフォルダのすべてのCSVファイルのファイル名を取得するのは、
Dir関数のヘルプの使用例が参考になるかと思います。

【38409】Re:複数のCSVファイルを一つのブックに
発言  かみちゃん  - 06/6/2(金) 8:23 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>そのファイルのデータを1つのブックに表示させたい

以下の過去ログも参考になるかと思います。
[#25952]
[#31445]

【38410】Re:複数のCSVファイルを一つのブックに
回答  maki  - 06/6/2(金) 8:29 -

引用なし
パスワード
   ▼かみちゃん さん:
>こんにちは。かみちゃん です。
さっそくのお返事どうもありがとうございます。
>一般操作でできると思いますので、この部分は「マクロの記録」でできるような気がします。
マクロの記録でやってみたのですがそれぞれのCSVファイルは毎回
(更新されるので)最終行が異なりそこのところが上手くできません。

>1つのブックであって、1つのシートではないのですか?
>別々のシートでいいのですか?
一つのシートに一覧で表示させたいのです。

>CSVファイルのフォーマットは、すべて一緒なのですか?
はい一緒です。

>1つのシートに追加していく場合、すべてのCSVファイルの総レコード数が65536を超えるとどうするのですか?
いえ超えません。一つのファイルの行数は1300〜1600ほどです。
ファイルが最高に増えても30個までだと思います。
>
>なお、特定のフォルダのすべてのCSVファイルのファイル名を取得するのは、
>Dir関数のヘルプの使用例が参考になるかと思います。
今から仕事に行ってきます。帰ったらそちらの関数を調べて
みます。ありがとうございました。

【38445】Re:複数のCSVファイルを一つのブックに
質問  maki  - 06/6/3(土) 8:27 -

引用なし
パスワード
   ▼かみちゃん さん:
すいません
また質問させてくださいませ
数十個あるCSVファイル名には
A000001
A000002
A000003
  ・
  ・
  ・
と末尾に番号がついてあって
一番最初に読み込むA000001だけ
1行から読み込みA000002からは
2行目から読み込むようにしたいのですが
どのような命令文になるのでしょうか
教えて下さいませ。どうぞ宜しくお願い
致します。

【38451】Re:複数のCSVファイルを一つのブックに
発言  かみちゃん  - 06/6/3(土) 10:21 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>一番最初に読み込むA000001だけ
>1行から読み込みA000002からは
>2行目から読み込むようにしたい

その前に、当初のご質問は、解決したのでしょうか?
今できているコードをアップすることはできませんか?
基本的には、どのファイルもすべての行を読み込んで、特定のファイル以外の場合
は、読み込んだあと、1行目だけを削除する、または、2行目以下をコピーするという
ことになるのですが・・・

【38453】Re:複数のCSVファイルを一つのブックに
回答  Hirofumi  - 06/6/3(土) 10:40 -

引用なし
パスワード
   時間が無いのでTestしていませんが、こんなで読めると思いますが?

Option Explicit

Public Sub CSVRead()
  
'  CSVデータの読み込み
  
  Const ForReading = 1

  Dim i As Long
  Dim rngWrite As Range
  Dim lngRow As Long
  Dim strPath As String
  Dim vntFileNames As Variant
  Dim vntField As Variant
  Dim strBuff As String
  Dim objFso As Object
  Dim objFileStr As Object
  Dim blnHeader As Boolean
  Dim strBaseName As String
  Dim strProm As String
  
  '書き込む位置を設定
  Set rngWrite = ActiveSheet.Cells(1, "A")
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  '読み込むファイルのフォルダを設定
  strPath = "C:\Documents and Settings\All Users\デスクトップ\CSVフォルダ"
  
  '指定フォルダからファイル名を取得
  strBaseName = "^A[0-9][0-9][0-9][0-9][0-9][0-9]$"
  If Not GetFilesList(vntFileNames, strPath, objFso, strBaseName, "csv") Then
    strProm = "ファイルが有りません"
    GoTo Wayout
  End If
  
  Application.ScreenUpdating = False
  
  For i = 1 To UBound(vntFileNames)
    '指定ファイルを読み込みモードでOpen
    Set objFileStr = objFso.OpenTextFile(vntFileNames(i), ForReading)
    With objFileStr
      Do Until .AtEndOfStream
        'ファイルから1行読み込み
        strBuff = .ReadLine
        '「blnHeader = True」の場合其の行は書きこまない
        If Not blnHeader Then
          'CSVをフィールドに分割
          vntField = SplitCsv(strBuff, ",")
          '指定シートの指定行列位置について
          With rngWrite.Offset(lngRow)
            'フィールドの書き込み
            .Resize(, UBound(vntField) + 1).Value = vntField
          End With
          '書き込み行位置を更新
          lngRow = lngRow + 1
        End If
        'blnHeaderをFaseにして以降の行を書き込む
        blnHeader = False
      Loop
      'ファイルをClose
      .Close
      '「blnHeader = True」の場合其の行は書きこまない
      blnHeader = True
    End With
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set objFileStr = Nothing
  Set objFso = Nothing
  Set rngWrite = Nothing
  
  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

'      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 GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              objFso As Object, _
              Optional strNamePattan As String = ".*", _
              Optional strExtePattan As String = ".*") As Boolean
  
  Dim i As Long
  Dim objFiles As Object
  Dim objFile As Object
  Dim regExten As Object
  Dim regName As Object
  Dim vntRead() As Variant
  Dim strName As String

  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
 
  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If

  'regExtenpのオブジェクトを取得(正規表現を作成)
  Set regExten = CreateObject("VBScript.RegExp")
  With regExten
    'パターンを設定
    .Pattern = strExtePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
  Set regName = CreateObject("VBScript.RegExp")
  With regName
    'パターンを設定
    .Pattern = strNamePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With

  'フォルダオブジェクトを取得
  Set objFiles = objFso.GetFolder(strFilePath).Files

  'ファイルの数が0でなければ
  If objFiles.Count <> 0 Then
    For Each objFile In objFiles
      With objFile
        strName = .Path
        '検索をテスト
        If regExten.test(objFso.GetExtensionName(strName)) Then
          If regName.test(objFso.GetBaseName(strName)) Then
            i = i + 1
            ReDim Preserve vntRead(1 To i)
            vntRead(i) = strName
          End If
        End If
      End With
    Next objFile
  End If

  Set regExten = Nothing
  Set regName = Nothing

  If i <> 0 Then
    ShellSort vntRead
    vntFileNames = vntRead
    GetFilesList = True
  End If

Wayout:

  'フォルダオブジェクトを破棄
  Set objFiles = Nothing
  Set objFile = Nothing
  
End Function

Private Sub ShellSort(vntList As Variant)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim vntTmp As Variant
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(vntList, 1)
  lngEnd = UBound(vntList, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap <= 0
    For i = lngGap + lngTop To lngEnd
      vntTmp = vntList(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(j - lngGap) <= vntTmp Then
          Exit For
        End If
        vntList(j) = vntList(j - lngGap)
      Next j
      vntList(j) = vntTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【38455】Re:複数のCSVファイルを一つのブックに
回答  かみちゃん  - 06/6/3(土) 11:14 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>今できているコードをアップすることはできませんか?

本当は、makiさんがどこまでできているのかをご提示いただきたいのですが、
Hirofumiさんからコードの提示もあったので、私も「マクロの記録」とヘルプ
の引用で作れるコードを提示させていただきます。

Hirofumiさんのコードは、とてもすばらしいコードで、過去何度となく同様の
コードを掲示板でご紹介されていたので、後ほど、過去ログを紹介しようとし
ていましたが、少々長いので、解析・勉強され理解されるのは大変ではなかろ
うかと思います。僭越ながら、私のコードも何かのお役に立てれば幸いです。

Sub Macro1()
 Dim MyPath As String
 Dim MyName As String
 Dim strCsvFileName As String
 Dim rngPaste As Range

 MyPath = ThisWorkbook.Path
 MyName = Dir(MyPath & "\*.csv")
 Do While MyName <> ""
  strCsvFileName = MyPath & "\" & MyName
  
  '貼付先を取得(このブックのアクティブシートに貼付け)
  Set rngPaste = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp)
  If rngPaste.Value <> "" Then
   Set rngPaste = rngPaste.Offset(1)
  End If
  
  'Csvファイルを開く
  Workbooks.Open strCsvFileName
  
  '特定のファイルの場合は、1行目を削除
  If MyName = "A000001.csv" Then
   Rows(1).Delete Shift:=xlUp
  End If
  
  '読み込んだCSVファイルを貼付け先に貼付けて閉じる
  Range("A1").CurrentRegion.Copy rngPaste
  ActiveWorkbook.Close False
  
  MyName = Dir
 Loop
End Sub

【38458】Re:複数のCSVファイルを一つのブックに
発言  かみちゃん  - 06/6/3(土) 12:03 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>時間が無いのでTestしていませんが、こんなで読めると思いますが?

ちょうど、別の案件で使おうとしていましたので、私のほうで検証してみました。
私の手元にあるCSVファイルが悪いのかもしれませんが、ファイルの末尾がEOFに
なっている場合、EOFコードまで、Excelシート上に読み込まれるようです。
したがって、それを除去する必要があると思い、以下のように修正してみて、き
れいに読み込めることを確認しました。

何かアドバイスがあれば、よろしくお願いします。

        'ファイルから1行読み込み
        strBuff = .ReadLine
        
        If Len(strBuff) <> 0 Then
         'ファイルの末尾がEnd Of File (16進数の1A、文字コードの26)である場合は、除去
         strBuff = Replace(strBuff, Chr(26), "")
         '読み込んだ行がEnd Of File のみだった場合は、其の行は書きこまない
         If Len(strBuff) = 0 Then blnHeader = True
        End If
        
        '「blnHeader = True」の場合其の行は書きこまない
        If Not blnHeader Then

【38461】Re:複数のCSVファイルを一つのブックに
発言  Hirofumi  - 06/6/3(土) 14:23 -

引用なし
パスワード
   たしか、殆どのWindowsのアプリケーションで出力されるTextは、Eof「&H1A」が付けられないし、
通常使っているOpenステートメントは、「&H1A」を検出した位置で読み込み終了と成り、
「&H1A」出力されないので忘れていました
(FsoでTextを読む場合「&H1A」も通常の文字として読み込む様ですね)
「&H1A」が出力されるTextの場合(Dosの頃の仕様?)は、其の処理が必要と成ると思います
1つは、かみちゃんさんの様な処理をするか?
若しくは、Openステートメントを使って以下の様にすれば善いと思います

Public Sub CSVRead()
  
'  CSVデータの読み込み
  
  Dim i As Long
  Dim rngWrite As Range
  Dim lngRow As Long
  Dim strPath As String
  Dim dfn As Integer
  Dim vntFileNames As Variant
  Dim vntField As Variant
  Dim strBuff As String
  Dim objFso As Object
  Dim objFileStr As Object
  Dim blnHeader As Boolean
  Dim strBaseName As String
  Dim strProm As String
  
  '書き込む位置を設定
  Set rngWrite = ActiveSheet.Cells(1, "A")
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  '読み込むファイルのフォルダを設定
  strPath = "C:\Documents and Settings\All Users\デスクトップ\CSVフォルダ"
  
  '指定フォルダからファイル名を取得
  strBaseName = "^A[0-9][0-9][0-9][0-9][0-9][0-9]$"
  If Not GetFilesList(vntFileNames, strPath, objFso, strBaseName, "csv") Then
    strProm = "ファイルが有りません"
    GoTo Wayout
  End If
  
  Application.ScreenUpdating = False
  
  For i = 1 To UBound(vntFileNames)
    '指定ファイルを読み込みモードでOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      '「blnHeader = True」の場合其の行は書きこまない
      If Not blnHeader Then
        'CSVをフィールドに分割
        vntField = SplitCsv(strBuff, ",")
        '指定シートの指定行列位置について
        With rngWrite.Offset(lngRow)
          'フィールドの書き込み
          .Resize(, UBound(vntField) + 1).Value = vntField
        End With
        '書き込み行位置を更新
        lngRow = lngRow + 1
      End If
      'blnHeaderをFaseにして以降の行を書き込む
      blnHeader = False
    Loop
    'ファイルをClose
    Close #dfn
    '「blnHeader = True」の場合其の行は書きこまない
    blnHeader = True
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set objFileStr = Nothing
  Set objFso = Nothing
  Set rngWrite = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

尚、書き忘れましたが、読み込むCsvファイルの名前は、
Aが先頭で且つ、6桁の数字から成るファイル限定ですので気を付けて下さい
また、此れをアルファベット1文字が先頭で、6桁の数字から成るファイルとしたいなら
以下の様にして下さい

  '指定フォルダからファイル名を取得
  strBaseName = "^A[0-9][0-9][0-9][0-9][0-9][0-9]$"



  '指定フォルダからファイル名を取得
  strBaseName = "^[A-Z][0-9][0-9][0-9][0-9][0-9][0-9]$"

とします

【38466】Re:複数のCSVファイルを一つのブックに
回答  Kein  - 06/6/3(土) 15:53 -

引用なし
パスワード
   DAO を使ってアクティブシートにデータをインポートする、というマクロを
提示します。
VBEのメニュー「ツール」「参照設定」で "Microsoft DAO 3.6 Library" に
チェックを付けて、空白シートを開いて実行して下さい。
なお、CSVファイルの保存先フォルダーのパスは、定数 Ph として宣言してますが
正確なパスではありませんので、そちらで変更して下さい。

Sub MyCSV_CopyByDAO()
  Dim WS As DAO.Workspace
  Dim DB As DAO.Database
  Dim RS As DAO.Recordset
  Dim i As Long
  Dim Cnt As Boolean
  Dim MyF As String, TNm As String
  Const Ph As String = _
  "C:\Documents and Settings\User\デスクトップ\CSVフォルダ"
 
  MyF = Dir(Ph & "\*.csv")
  If MyF = "" Then
   MsgBox "CSVファイルが見つかりません", 48: Exit Sub
  End If
  Set WS = DBEngine.Workspaces(0)
  Do Until MyF = ""
   TNm = Left$(MyF, Len(MyF) - 4)
   Name Ph & "\" & MyF As Ph & "\" & TNm & ".txt"
   Set DB = WS.OpenDatabase(Ph, 0, 0, "Text;")
   Set RS = DB.OpenRecordset(TNm)
   If Cnt = False Then
     For i = 0 To RS.Fields.Count - 1
      Cells(1, i + 1).Value = RS.Fields(i).Name
     Next i
     Cnt = True
   End If
   Range("A65536").End(xlUp).Offset(1) _
   .CopyFromRecordset RS
   RS.Close: DB.Close
   Set RS = Nothing: Set DB = Nothing
   Name Ph & "\" & TNm & ".txt" As Ph & "\" & MyF
   MyF = Dir()
  Loop
  Set WS = Nothing
End Sub

【38467】Re:複数のCSVファイルを一つのブックに
発言  Kein  - 06/6/3(土) 15:56 -

引用なし
パスワード
   訂正。
> "Microsoft DAO 3.6 Library"


"Microsoft DAO 3.6 Object Library

です。
なお、Excelのバージョンによっては DAO のバージョンも変化
しますから、最新のものにチェックを付けて下さい。

【38493】Re:複数のCSVファイルを一つのブックに
お礼  maki  - 06/6/5(月) 0:19 -

引用なし
パスワード
   皆様 親切にお答えくださってとても感謝しております。
かみちゃんさん、Hirofumiさん、Keinさん
本当にありがとうございました。
大変お恥かしいのですが、私はごく簡単なマクロしかできません。
現在本で勉強しているところです。ですので今回はKein さんの
提示していただいたマクロを使わせていただきます。
先頭のファイルは1行目からそしてそれ以降のファイルは
2行目からスラスラと読みこみ、大変感動しております。
ちなみにDAOは3.51でした。
皆様ありがとうございました。

7535 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free