Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1541 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【73569】2つ目以降のcsvのタイトル行を削除しつつ結合するには にしもり 13/1/23(水) 2:33 質問[未読]
【73571】Re:2つ目以降のcsvのタイトル行を削除しつ... kanabun 13/1/23(水) 9:26 発言[未読]
【73572】Re:2つ目以降のcsvのタイトル行を削除しつ... UO3 13/1/23(水) 9:41 発言[未読]
【73574】Re:2つ目以降のcsvのタイトル行を削除しつ... にしもり 13/1/23(水) 11:46 お礼[未読]
【73575】Re:2つ目以降のcsvのタイトル行を削除しつ... kanabun 13/1/23(水) 13:03 発言[未読]
【73702】Re:2つ目以降のcsvのタイトル行を削除しつ... にしもり 13/2/5(火) 19:03 質問[未読]
【73704】Re:2つ目以降のcsvのタイトル行を削除しつ... kanabun 13/2/5(火) 20:06 発言[未読]
【73714】Re:2つ目以降のcsvのタイトル行を削除しつ... にしもり 13/2/6(水) 11:35 質問[未読]
【73722】Re:2つ目以降のcsvのタイトル行を削除しつ... kanabun 13/2/6(水) 18:22 発言[未読]
【73728】Re:2つ目以降のcsvのタイトル行を削除しつ... kanabun 13/2/6(水) 22:58 発言[未読]
【73738】Re:2つ目以降のcsvのタイトル行を削除しつ... にしもり 13/2/7(木) 14:09 お礼[未読]
【73569】2つ目以降のcsvのタイトル行を削除しつつ...
質問  にしもり  - 13/1/23(水) 2:33 -
引用なし
パスワード
   こんにちは。
複数のcsvを結合したいのですが、2つ目以降のcsvのタイトル行を削除しつつ結合したいとき、どうすればよろしいでしょうか。
よろしくお願いします。

Sub Test()
Dim Files, FilesCnt As Integer, i As Integer
Dim cBook As Workbook, pBook As Workbook

　Files = Application.GetOpenFilename _
　　　　(FileFilter:="CsVFile(*.csv), *.csv", MultiSelect:=True)
　If IsArray(Files) Then
　　 Set pBook = Workbooks.Add(xlWBATWorksheet)
　　 FilesCnt = UBound(Files)
　　 For i = 1 To FilesCnt
　　　　 Workbooks.Open Files(i)
　　　　 Set cBook = ActiveWorkbook
　　　　 cBook.ActiveSheet.UsedRange.Copy
　　　　
　　　　
　　　'　　　 With ActiveSheet.QueryTables.Add(Connection:= _
　　　'　"TEXT;" & fname, Destination:=Range("A2"))
　　　　
　　　　 With pBook.ActiveSheet
　　　　　 .Cells(.Range("A65536").End(xlUp).Row, 1). _
　　　　　 PasteSpecial (xlPasteAll)
　　　　 End With
　　　　 Application.CutCopyMode = False
　　　　 cBook.Close
　　 Next i
　End If
Set cBook = Nothing: Set pBook = Nothing
End Sub
【73571】Re:2つ目以降のcsvのタイトル行を削除し...
発言  kanabun  - 13/1/23(水) 9:26 -
引用なし
パスワード
   ▼にしもり さん：こんにちは

>複数のcsvを結合したいのですが、2つ目以降のcsvのタイトル行を削除しつつ結合したいとき、どうすればよろしいでしょうか。

Bookとして開いてシート展開してるんですよね

>　　　　 Workbooks.Open Files(i)
>　　　　 Set cBook = ActiveWorkbook
>　　　　 cBook.ActiveSheet.UsedRange.Copy

↑(i > 1) のときは、1行目を削除してから Copy するとか？
【73572】Re:2つ目以降のcsvのタイトル行を削除し...
発言  UO3  - 13/1/23(水) 9:41 -
引用なし
パスワード
   ▼にしもり さん：

kanabunさんからの回答に加えて、以下のような方法も。

１．i>1 なら cBook.ActiveSheet.UsedRange.OffSet(,1).Copy
　　（厳密に言えば、行数もResizeで１つ減らす必要がありますが、まぁ、大丈夫でしょう）

２．i>1 なら　コピーした後、その時のコピー先頭行を削除
【73574】Re:2つ目以降のcsvのタイトル行を削除し...
お礼  にしもり  - 13/1/23(水) 11:46 -
引用なし
パスワード
   ▼kanabunさん、UO3 さん：

アドバイスまことにありがとうございます。

行を削除するので
cBook.ActiveSheet.UsedRange.Offset(1, 0).Copy
でございますよね。

アドバイスを参考に下記の通りできました。
深く感謝いたします。

Sub Test()
Dim Files, FilesCnt As Integer, i As Integer
Dim cBook As Workbook, pBook As Workbook

　Files = Application.GetOpenFilename _
　　　　(FileFilter:="CsVFile(*.csv), *.csv", MultiSelect:=True)
　If IsArray(Files) Then
　　 Set pBook = Workbooks.Add(xlWBATWorksheet)
　　 FilesCnt = UBound(Files)
　　 For i = 1 To FilesCnt
　　　　 Workbooks.Open Files(i)
　　　　 Set cBook = ActiveWorkbook
'修正　　　　
　　　　 If i > 1 Then
　　　　　　cBook.ActiveSheet.UsedRange.Offset(1, 0).Copy
　　　　 Else
　　　　　　cBook.ActiveSheet.UsedRange.Copy
　　　　 End If
　　　　　
　　　　 With pBook.ActiveSheet
　　　　　 .Cells(.Range("A65536").End(xlUp).Row, 1). _
　　　　　 PasteSpecial (xlPasteAll)
　　　　 End With
　　　　 Application.CutCopyMode = False
　　　　 cBook.Close
　　 Next i
　End If
　
'追加
　　
　　ActiveWorkbook.SaveAs Filename:="C:\Digital_yyyymmdd.csv", FileFormat:= _
　　xlOpenXMLWorkbook, CreateBackup:=False
　　
　　ActiveWorkbook.Close Filename:="C:\Digital_yyyymmdd.csv"
　　
　　MsgBox "終了しました。"

　　
Set cBook = Nothing: Set pBook = Nothing
End Sub
　
【73575】Re:2つ目以降のcsvのタイトル行を削除し...
発言  kanabun  - 13/1/23(水) 13:03 -
引用なし
パスワード
   ▼にしもり さん：

解決されたようで何よりですが、
BookとしてOpenする方法でない方法を紹介しておきます。
参考にしてください。

Sub JoinCSV()
　Dim Files, outFilename As String
　Dim myPath As String
　Dim i As Long
　Dim io As Integer, oo As Integer
　Dim buf() As Byte
　Dim ss As String

　Files = Application.GetOpenFilename _
　　　　(FileFilter:="CSV, *.csv", MultiSelect:=True)
　If IsArray(Files) Then
　　　i = InStrRev(Files(1), "\")
　　　myPath = Left$(Files(1), i - 1)
　　　outFilename = Application.GetSaveAsFilename( _
　　　　　　　　　　myPath & "\JoinCSV.csv", "CSV,*.csv")
　　　If outFilename = "False" Then Exit Sub
　　　oo = FreeFile()
　　　Open outFilename For Output As oo '初期化
　　　Close oo
　　　Open outFilename For Binary As oo
　　　
　　　io = FreeFile()
　　　For i = 1 To UBound(Files)
　　　　　Open Files(i) For Binary As io
　　　　　ReDim buf(1 To LOF(io))
　　　　　Get io, , buf
　　　　　Close io
　　　　　If i = 1 Then　 'そのままバイトデータをPut
　　　　　　　Put oo, 1, buf
　　　　　Else　　　　　　'1行目を削除してPut
　　　　　　　ss = StrConv(buf, vbUnicode)
　　　　　　　ss = Split(ss, vbCrLf, 2)(1)
　　　　　　　Put oo, , ss
　　　　　End If
　　　Next
　　　Close oo
　End If
End Sub

◆検証していて気がついたのですが、

>　Files = Application.GetOpenFilename _
>　　　　(FileFilter:="CSV, *.csv", MultiSelect:=True)

GetOpenFilename は複数ファイルを選択でき便利なのですが、
ユーザーの選択順を変えるのが難点ですね。
たとえば、$1.csv, $2.csv, $3.csv のファイルをこの順番にダイアログで
選択しても、Files() 内は $3.csv, $1.csv, $2.csv に変更されてしまいます。
順番を指定して結合したいばあいには、GetOpenFilename は使えないですね
【73702】Re:2つ目以降のcsvのタイトル行を削除し...
質問  にしもり  - 13/2/5(火) 19:03 -
引用なし
パスワード
   ▼kanabun さん：
仰るとおりの問題が起きましたので、恐れ入りますが
下記を使わせていただいております。
保存の際ダイアログが現れるロジックになっておりますが、自動でtest.csvという名でCドライブMy Documentに保存するにはどうしたらいいでしょうか。
worksheetならこんな感じかとおもいますが、csvのまま保存する記述がすみませんが解っておりません。
ご教示よろしくお願いします。

Sub JoinCSV()
　Dim Files, outFilename As String
　Dim myPath As String
　Dim i As Long
　Dim io As Integer, oo As Integer
　Dim buf() As Byte
　Dim ss As String

　Files = Application.GetOpenFilename _
　　　　(FileFilter:="CSV, *.csv", MultiSelect:=True)
　If IsArray(Files) Then
　　　i = InStrRev(Files(1), "\")
　　　myPath = Left$(Files(1), i - 1)
　　　outFilename = Application.GetSaveAsFilename( _
　　　　　　　　　　myPath & "\JoinCSV.csv", "CSV,*.csv")

　' worksheetならこんな感じかと
　' ActiveSheet.SaveAs _
　'　FileName:=ThisWorkbook.Path & "\test.csv", _
　'　FileFormat:=xlCSV


　　　If outFilename = "False" Then Exit Sub
　　　oo = FreeFile()
　　　Open outFilename For Output As oo '初期化
　　　Close oo
　　　Open outFilename For Binary As oo
　　　
　　　io = FreeFile()
　　　For i = 1 To UBound(Files)
　　　　　Open Files(i) For Binary As io
　　　　　ReDim buf(1 To LOF(io))
　　　　　Get io, , buf
　　　　　Close io
　　　　　If i = 1 Then　 'そのままバイトデータをPut
　　　　　　　Put oo, 1, buf
　　　　　Else　　　　　　'1行目を削除してPut
　　　　　　　ss = StrConv(buf, vbUnicode)
　　　　　　　ss = Split(ss, vbCrLf, 2)(1)
　　　　　　　Put oo, , ss
　　　　　End If
　　　Next
　　　Close oo
　End If
End Sub
【73704】Re:2つ目以降のcsvのタイトル行を削除し...
発言  kanabun  - 13/2/5(火) 20:06 -
引用なし
パスワード
   ▼にしもり さん：こんにちは〜

まず、後半の質問から。

>保存の際ダイアログが現れるロジックになっておりますが、
> 自動でtest.csvという名でCドライブMy Documentに保存するにはどうしたらいいでしょうか。

これについては、My Documentsフォルダを取得する一般的なやりかたがあります。
下のコードの
'-----------------------------------------------------------------　
'-----------------------------------------------------------------　
のなかを参照してください。

Sub JoinCSV3()
　Dim Files, outFilename As String
　Dim myPath As String
　Dim i As Long
　Dim io As Integer, oo As Integer
　Dim buf() As Byte
　Dim ss As String

　Files = Application.GetOpenFilename _
　　　　(FileFilter:="CSV, *.csv", MultiSelect:=True)

　If IsArray(Files) Then
'-----------------------------------------------------------------　
　　　outFilename = CreateObject("WScript.Shell"). _
　　　　　　　　　　SpecialFolders("MyDocuments") & "\test.csv"
'-----------------------------------------------------------------　　　
　　　oo = FreeFile()
　　　Open outFilename For Output As oo '初期化
　　　Close oo
　　　Open outFilename For Binary As oo
　
　　　io = FreeFile()
　　　For i = 1 To UBound(Files)
　　　　　Open Files(i) For Binary As io
　　　　　ReDim buf(1 To LOF(io))
　　　　　Get io, , buf
　　　　　Close io
　　　　　If i = 1 Then　　　 'そのままバイトデータをPut
　　　　　　　Put oo, 1, buf
　　　　　Else　　　　　　　　'1行目を削除してPut
　　　　　　　ss = StrConv(buf, vbUnicode)
　　　　　　　ss = Split(ss, vbCrLf, 2)(1)
　　　　　　　Put oo, , ss
　　　　　End If
　　　Next
　　　Close oo
　End If
End Sub


----
さて、前半の

> 仰るとおりの問題が起きましたので、恐れ入りますが
> 下記を使わせていただいております。

の件ですが、その「問題」というのが
GetOpenFilename メソッドの（XL2002, 2003 での）不具合のことでしたら、
いかんせん、ぼくのサンプルコードでも何ら不具合は修正されてません。
1.csv, 2.csv, 3.csv, 4.csv というファイルがあって、
それを 1 〜 4 の順番で読み結合したいのなら、XL2002, 2003 では 今の
ままで うまくいきません。

また、こうすればよい、という簡単明快な方法も知らないです。
ずっとむかし、UserForm を利用してユーザーに順番を並び替えさせるプロ
シージャを作ったことはありますが... めんどくさいです。

同じようにめんどうですが、
たとえば、Excelが2002か2003だったら、
GetOpenFilenameで選択した複数CSVファイルを いちどワークシートに書き
出して、ユーザーに 並び替えさせて結合順を指定なおす → プログラムを
2つに分ける
ような方法も考えられます。

いずれにしても 「問題が起きました」とおっしゃるのは、そのファイル選択
順が反映されないということですか？
【73714】Re:2つ目以降のcsvのタイトル行を削除し...
質問  にしもり  - 13/2/6(水) 11:35 -
引用なし
パスワード
   ▼kanabun さん：
後半の質問 については、
自分でも調べてMy DocumentsのほかにもFavoritesとか特殊フォルダに保存する方法を知りました。有難うございました。
ですがもう1点、逆にDドライブとか普通のフォルダに（Worksheetにしていないものを）test.csvの名で保存する方法がわかりません。
こう書きましたができません。↓
　　　outFilename = CreateObject("WScript.Shell"). _
　　　 ("\D" & "\test.csv")
どうすればいいかご教示下さいませんでしょうか？


前半の「問題」とは、わたしの勘違いでして、
選択順が反映されないことだったのですが、それは反映されていなくてもいいことになりました。

なお、Worksheetにして結合する方法だと、行数が65000行を超えると
それ以後タイトル行が消えてしまうことが判り、その点は問題だったのでcsvのまま結合する方法を採らせていただきました。
【73722】Re:2つ目以降のcsvのタイトル行を削除し...
発言  kanabun  - 13/2/6(水) 18:22 -
引用なし
パスワード
   ▼にしもり さん：

>ですがもう1点、逆にDドライブとか普通のフォルダに（Worksheetにしていないものを）test.csvの名で保存する方法がわかりません。
>こう書きましたができません。↓
>　　　outFilename = CreateObject("WScript.Shell"). _
>　　　 ("\D" & "\test.csv")

そこは単に

　　　outFilename = "D:\test.csv"

でいいです。
【73728】Re:2つ目以降のcsvのタイトル行を削除し...
発言  kanabun  - 13/2/6(水) 22:58 -
引用なし
パスワード
   ▼にしもり さん：

それから、Sub JoinCSV3()方式によるテキストファイルの結合のことなんですが、

>If i = 1 Then　　　 'そのままバイトデータをPut
>　　　　　　　Put oo, 1, buf
>　　　　　Else　　　　　　　　'1行目を削除してPut
>　　　　　　　ss = StrConv(buf, vbUnicode)
>　　　　　　　ss = Split(ss, vbCrLf, 2)(1)
>　　　　　　　Put oo, , ss
>　　　　　End If

他の掲示板でちょっと質問してみたところ、いろいろ改良案が寄せられました。

如何に効率よく処理するかってことですが、
気が向いたら、参考になさってください。
ht tp://moug.net/faq/viewtopic.php?t=65166
の
とくに
投稿日時: 13/01/29 00:51:39 投稿者: kanabun
以降のレスがそれです。
【73738】Re:2つ目以降のcsvのタイトル行を削除し...
お礼  にしもり  - 13/2/7(木) 14:09 -
引用なし
パスワード
   ▼kanabun さん：

ありがとうございます。
Dに保存が出来ました。

また、他の掲示板でも話題にして下さったのは元はわたしの質問についてではないかと思います。
ありがとうございます。

拝見しましてレベルの高いやりとりについていけないことはわかりましたが、
それでも次回なんからの問題が起きたときに拝見ししてみようと思います。

どうもありがとうざいました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1541 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free