[[20110705155353]]　『指定フォルダのCSVをシートを分けて全て取り込む』（いち）　ページの最後に飛ぶ

『指定フォルダのCSVをシートを分けて全て取り込む』（いち）

 マクロ初心者です。
 マクロで指定のフォルダの中に複数あるCSVファイルを全てSheet毎に分けて
 取り込みた いのですが、どうすればよいでしょうか。
 またSheet名はCSVのファイル名（拡張子の前部分）にしたいです。
 よろしくお願い致します。

 一例

 Sub csv取り込み()
    Dim myPath As String
    Dim myCsv As String

    myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")  '適宜変更
    myCsv = Dir(myPath & "\*.csv")
    Do While Len(myCsv) > 0
        Workbooks.Open myPath & "\" & myCsv
        ActiveSheet.Name = Split(myCsv, ".")(0)
        ActiveWorkbook.Sheets(1).Move after:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)
        myCsv = Dir()
    Loop

 End Sub

 ぶらっと立ち寄り

マクロ作成ありがとうございます。

 ActiveWorkbook.Sheets(1).Move after:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)
 のところでエラーになってしまいました。
どうしたら良いでしょうか？（いち）

 Sub test()
 Dim myObj As Object
 Dim myDir As String
 Dim myFileName As String
 Dim myc As Long
 Application.ScreenUpdating = False
 Set myObj = CreateObject("Shell.Application"). _
          BrowseForFolder(0, "取り込むフォルダを選択してください", 0)
          If myObj Is Nothing Then Exit Sub

          myDir = myObj.Items.Item.Path
          If Right(myDir, 1) <> "\" Then myDir = myDir & "\"
        'フォルダ内のExcelファイルを確認
          myFileName = Dir(myDir & "*.csv")
          myc = 0
          Do While myFileName <> ""
           Workbooks.Open (myDir & myFileName)
            myc = myc + 1
            Workbooks(myFileName).Worksheets(1).Move ThisWorkbook.Worksheets(1)
            myFileName = Dir()
          Loop
          If myc = 0 Then
             MsgBox "CSVファイルがありません。"
          End If
 Application.ScreenUpdating = True
 End Sub
 こんなのはどう？　　mama

 >のところでエラーになってしまいました。

 こちらでは、もちろん動くんだけど、
 ・エラーメッセージはどんなものでしたか？
 ・ActiveWorkbook.Sheets(1).Move after:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)
   これを
   ActiveSheet.Move after:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)
   にしても同じエラー？

 ぶらっと立ち寄り

 シートの移動や複製はデータ量によっては、エラーになります。
 ディスクが足りません。とかでて。
 知らないのかな？
 Bj

 私も最初、ぶらっと立ち寄りさんのコードでエラーになりました。
 「アプリケーション定義またはオブジェクト定義のエラー」のメッセージです。

 なんでだろ？と思って模索していたら
 私の環境はExcel2007で互換モードが標準なのですが
 単にWorkBooks.OpenでCsvを開くと2007の標準モードで開くので
 シートの行列範囲の違いでエラーになっていたようです。

 状況が該当するかわかりませんが、参考程度に。

 作られるシート数によってもエラーになりそうですね。
 （ｍｏｍｏ）

 >私の環境はExcel2007で互換モードが標準なのですが
 >単にWorkBooks.OpenでCsvを開くと2007の標準モードで開くので
 >シートの行列範囲の違いでエラーになっていたようです。

 ｍｏｍｏさん、アドバイス深謝。なぁるほど。しばらくは(自分のような）2003心中派？や
 互換モード派、さらには、もう2003はさよなら派、xlsmしか使わない派。。。
 いろんな環境が混在するので、ややこしくなりそうですなぁ・・・

 ということで、いちさんの環境も2007がらみなら、別の手当てが必要だね。
 でも、もし、実行時のメモリー状況によるものなら、ひょっとすると、以下のようにすると
 エラーにならないかも？

 Sub csv取り込み()
    Dim myPath As String
    Dim myCsv As String

    myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")  '適宜変更
    myCsv = Dir(myPath & "\*.csv")
    Do While Len(myCsv) > 0
        Workbooks.Open myPath & "\" & myCsv
        ActiveSheet.Name = Split(myCsv, ".")(0)
        ActiveWorkbook.Sheets(1).Move after:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)
        DoEvents
        DoEvents
        DoEvents
        DoEvents
        DoEvents
        myCsv = Dir()
    Loop

 End Sub

 使用しているのはExcel2010です。
 エラーメッセージは
 実行時エラー1004「移動先またはコピー先のブックの行列数が
 元のブックの行列数よりも少ないため、シートを移動先または
 コピー先に挿入できません。・・・・・・・」とでます。
 最後のマクロも同じエラーです。
 手作業でcsvのSheetをExcelBookにコピーしても同じエラーメッセージが
 出ました。シートの移動は無理でしょうか？
 もしそうでしたら、各CSV毎にExcelBookにシートを新規挿入して、
 csvのシートを全選択して、 ExcelBookのシートにペーストして、
 シート名は各CSVの名前になるようにということは出来ますでしょうか？
 注文が多くて申し訳ございません。よろしくお願い致します。（いち）

 私のと同じ状況のようですね。
 ぶらっと立ち寄りさんのコードでも、ちょっと変更すれば出来そうです。
 以下で試してみてください
 なお、元のCSVに変更をしないように同じフォルダにブックを保存する仕様にしています。

 Sub csv取り込み()
    Dim myPath As String
    Dim myCsv As String
    Dim wb As Workbook
    myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")  '適宜変更
    myCsv = Dir(myPath & "\*.csv")
    Do While Len(myCsv) > 0
        Workbooks.Open myPath & "\" & myCsv
        ActiveSheet.Name = Split(myCsv, ".")(0)
        If wb Is Nothing Then
          Set wb = ActiveWorkbook
        Else
          ActiveWorkbook.Sheets(1).Move after:=wb.Sheets(wb.Sheets.Count)
        End If
        myCsv = Dir()
    Loop
    wb.SaveAs myPath & "CSVtmp.xlsx", xlOpenXMLWorkbook
    Set wb = Nothing
 End Sub

 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
 他の方のコードをお借りしてばかりなので、私のやり方だと

  Sub csv取り込み2()
  Dim n      As Integer
  Dim buf()  As Byte
  Dim myCSV  As String
  Dim myPath As String
  Dim tbl    As Variant
  myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")  '適宜変更
  myCSV = Dir(myPath & "\*.csv")
  Do While Len(myCSV) > 0
    n = FreeFile
    Open myCSV For Binary As n
      ReDim buf(1 To LOF(n))
      Get #n, , buf
    Close n
    tbl = Application.Transpose(Split(StrConv(buf, vbUnicode), vbCrLf))
    With ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
      .Cells.NumberFormatLocal = "@"
      With .Range("A1").Resize(UBound(tbl))
        .Value = tbl
        .TextToColumns Destination:=.Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False
      End With
      .Name = Split(myCSV, ".")(0)
    End With
    myCSV = Dir()
  Loop
  End Sub

 こんな感じです。
 （ｍｏｍｏ）

 別案で
 Sub tset()
Dim myDir As String, fn As String, n As Long
Dim txt As String, x, y(), i As Long, maxCol As Long
myDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
fn = Dir(myDir & "\*.csv")
Do While fn <> ""
    txt = CreateObject("scripting.filesystemobject").opentextfile(myDir & "\" & fn).readall
    x = Split(txt, vbCrLf)
    ReDim y(UBound(x))
    For i = 0 To UBound(x)
        y(i) = Split(x(i), ",")
        maxCol = Application.Max(maxCol, UBound(y(i)) + 1)
    Next
    y = Application.Transpose(Application.Transpose(y))
    n = n + 1
    If n > Sheets.Count Then Sheets.Add after:=Sheets(Sheets.Count)
    With Sheets(n)
        .Cells(1).Resize(UBound(y) + 1, maxCol).Value = y
        .Name = Split(fn, ".")(0)
    End With
    maxCol = 0
    fn = Dir
Loop
End Sub
(seiya)
修正有

コメント返信：

[ 一覧(最新更新順) ]

[[20110705155353]] 『指定フォルダのCSVをシートを分けて全て取り込む』（いち） ページの最後に飛ぶ

[[20110705155353]]　『指定フォルダのCSVをシートを分けて全て取り込む』（いち）　ページの最後に飛ぶ