Excel VBA質問箱 IV

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

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


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

【74845】複数のCSVファイルを開き、抽出、別シートの空白セルに貼り付けしたい マスク 13/9/29(日) 10:34 質問[未読]
【74847】Re:複数のCSVファイルを開き、抽出、別... kanabun 13/9/29(日) 17:29 発言[未読]
【74848】Re:複数のCSVファイルを開き、抽出、別... マスク 13/9/29(日) 18:35 質問[未読]
【74849】Re:複数のCSVファイルを開き、抽出、別... kanabun 13/9/29(日) 19:11 発言[未読]
【74850】Re:複数のCSVファイルを開き、抽出、別... マスク 13/9/29(日) 19:45 質問[未読]
【74851】Re:複数のCSVファイルを開き、抽出、別... kanabun 13/9/29(日) 20:08 質問[未読]
【74852】Re:複数のCSVファイルを開き、抽出、別... マスク 13/9/29(日) 21:23 お礼[未読]
【74854】Re:複数のCSVファイルを開き、抽出、別... kanabun 13/9/30(月) 10:51 発言[未読]
【74855】Re:複数のCSVファイルを開き、抽出、別... マスク 13/10/2(水) 21:55 お礼[未読]

【74845】複数のCSVファイルを開き、抽出、別シ...
質問  マスク  - 13/9/29(日) 10:34 -

引用なし
パスワード
   はじめまして、VBA初心者のマスクと申します。
現在、標記の通りの
1、CSVファイルを読み込む
2、日付を入力し、その日付を含む行を抽出
3、別シートの空白列に貼り付けたい
4、また別のCSVファイルを開く
5、日付を入力し、その日付を含む行を抽出(2と同じ日付です)
6、別シートの空白列に貼り付けたい
(3でA1〜B4まで埋まっていたら、次はC1から貼り付けたい)
と続く感じのVBAマクロを作りたいと考えています。

色々と試行錯誤したのですが、上手く動かず、こちらに質問させていただきました。

まず、上記をADOやFSOを使い動かそうとやってみたのですが知識不足で上手く動きませんでした。
あと空白行を取得する事例は見つけることが出来るのですが、空白列を取得しそこに貼り付けるという動きをするような事例を見つけることが出来ず、そこがまったくの手つかずとなっています。

このようなプログラムを作るにはどういった関数を使えば良いかなどヒントでも良いので、教えてください。宜しくお願いします。

<考えた例>
Option Explicit

' テキストファイル読み込みサンプル3(FSO)
' 参照設定:Microsoft Scripting Runtime
Sub READ_TextFile3()
  ' 読み込むファイル名(固定)
  Const cnsFILENAME = "C:\TEMP\HOGE.txt"
  Dim FSO As New FileSystemObject' FileSystemObject
  Dim TS As TextStream      ' TextStream
  Dim strREC As String      ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行

  ' 指定ファイルをOPEN(入力モード)
  Set TS = FSO.OpenTextFile(cnsFILENAME, ForReading)
  GYO = 1
  ' ファイルのEOF(End of File)まで繰り返す
  Do Until TS.AtEndOfStream
    ' 改行までをレコードとして読み込む
    strREC = TS.ReadLine
    ' 行を加算しA列にレコード内容を表示(先頭は2行目)
    GYO = GYO + 1
    Cells(GYO, 1).Value = strREC
  Loop
  ' 指定ファイルをCLOSE
  TS.Close
  Set TS = Nothing
  Set FSO = Nothing
End Sub

  ' ファイルのEOF(End of File)まで繰り返す
の所に特定の文字列を検索し、抽出、別シートにコピーするようなコードを入れることが出来れば動くのではないかなーと色々試してみたのですが、上手くいきません。

<考えた例2>
Sub Sample()
Dim Cn As Object
Dim Rs As Object
Dim c As Object
Dim SQL As String
Dim Path As String
Dim key As String
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "CSVファイル", "*.csv", 1
.Filters.Add "全ファイル", "*.*", 2
.FilterIndex = 1
.Title = "ファイル選択"
.AllowMultiSelect = False
If .Show Then
Path = .SelectedItems(1)
Else
MsgBox "処理を中止します", 48
Exit Sub
End If
End With
Application.ScreenUpdating = False
On Error Resume Next
On Error GoTo 0
key = Inputbox("日付を入力してください")
Sheets.Add , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Choose(1, key)
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
With CreateObject("Scripting.FileSystemObject")
SQL = "Select * From " & .GetBaseName(Path) & "." & .GetExtensionName(Path) & _
" Where A1 Like '%" & Choose(1, Key) & "%' "
If Val(Application.Version) >= 12 Then
Cn.Provider = "Microsoft.Ace.OLEDB.12.0"
Else
Cn.Provider = "Microsoft.Jet.OLEDB.4.0"
End If
Cn.Properties("Extended Properties") = "Text;Hdr=No"
Cn.Open .GetParentFolderName(Path)
End With
Set Rs = Cn.Execute(SQL)
Range("空白列の一行目から").CopyFromRecordset Rs
Cn.Close
Set Cn = Nothing
Set Rs = Nothing
MsgBox "Finish", 64
End Sub

元のCSVファイルも、まとめる予定の別シートにも項目がないので
SQLのwhereの所に何を指定すればいいのか、A列でも可能なのか調べても
出てこなくて困っています。


インターネットで類似ソースを見つけ、改造するという手法で今まで簡単なツールは作成してきたので、知識不足だとは思いますが
助言を頂けたら助かります。

宜しくお願いします。

【74847】Re:複数のCSVファイルを開き、抽出、...
発言  kanabun  - 13/9/29(日) 17:29 -

引用なし
パスワード
   ▼マスク さん:

>1、CSVファイルを読み込む
>2、日付を入力し、その日付を含む行を抽出
>3、別シートの空白列に貼り付けたい
>4、また別のCSVファイルを開く
>5、日付を入力し、その日付を含む行を抽出(2と同じ日付です)
>6、別シートの空白列に貼り付けたい
>(3でA1〜B4まで埋まっていたら、次はC1から貼り付けたい)

少し分らない点があります

1. 複数CSVファイルはあるひとつのフォルダにあるのですか?
 特定のフォルダにある「すべてのCSVファイル」を開けばいいのか、
 ダイアログで選択した(限定された)CSVファイルを開くのか、
 どちらでしょう?

2. 日付けを含む行を抽出というと、フィルタが簡単かと思います。
 抽出したい日付はどこかに書いておくといいですね。
 抽出したい日付は特定の1日ですか?
 それとも 何月何日から何日まで というようなある期間でしょうか?

3. 抽出データは
> 別シートの空白列に貼り付けたい
ということですが、別シートは抽出用のために新規に作成したBookの
Sheet とかんがえていいですか? また、「空白列に」貼り付けるとは
どのようなことですか?

> A1〜B4まで埋まっていたら、次はC1から貼り付けたい
の意味が分りません。CSVデータは 2項目(2列)しかないのですか?
 

【74848】Re:複数のCSVファイルを開き、抽出、...
質問  マスク  - 13/9/29(日) 18:35 -

引用なし
パスワード
   はじめまして、宜しくお願いします。
書き方が分かりにくくて申し訳ないです。

返答
1、ダイアログで選択したCSVファイルを開きたいと考えています
2、抽出したい日付は特定の一日になります。
数が少ないのであればフィルタ抽出が簡単なのですが、数が多く、簡単に出来るようVBAマクロでツールを作成したいのです。
説明が下手で申し訳ないです。
3、新規のシートと考えて頂いて問題ありません。
空白列に貼り付けるというのは……
複数のCSVファイルは、異なる項目のデータが入っており、横に並べたいんですよね。CSVファイルの中身の項目数は月ごとに変化するので、明確な指定が出来ず、空白の列を見つけてそこに貼り付けて欲しいといったイメージで書きました。

> A1〜B4まで埋まっていたら、次はC1から貼り付けたい
の意味が分りません。CSVデータは 2項目(2列)しかないのですか?

の答えですが、CSVデータの列数は月ごとに変化してしまいます。
なので、別シートに貼り付ける時、どこに貼るかあらかじめ指定ができないので空白列を見つけて貼り付けられるようにできないか、というイメージで書きました。

CSVファイル1
8/1 はなこ 東京都
.
.
8/31 さえこ 埼玉

CSVファイル2
8/1 会社員 
.
.
8/31 主婦

CSVファイル3
8/1 300万 50万 3万
.
.
8/31 58万 40万 56万

というような三つのファイルがあるので(列数は月ごとにそれぞれ変化してしまう)
指定日→8/31
別シートに
8/31 さえこ 埼玉 8/31 主婦 8/31 58万 40万 56万

とまとめたいです。

分かりにくい説明で申し訳ありません。
心苦しいのですが、少しでも助言を頂ければ幸いです。

【74849】Re:複数のCSVファイルを開き、抽出、...
発言  kanabun  - 13/9/29(日) 19:11 -

引用なし
パスワード
   ▼マスク さん:


>返答
>1、ダイアログで選択したCSVファイルを開きたいと考えています
>2、抽出したい日付は特定の一日になります。
>数が少ないのであればフィルタ抽出が簡単なのですが、数が多く、簡単に出来るようVBAマクロでツールを作成したいのです。
もちろんマクロでAutoFilterをかけるわけです。

>空白列に貼り付けるというのは……
>複数のCSVファイルは、異なる項目のデータが入っており、横に並べたいんですよね。CSVファイルの中身の項目数は月ごとに変化するので、明確な指定が出来ず、空白の列を見つけてそこに貼り付けて欲しいといったイメージで書きました。
>
>> A1〜B4まで埋まっていたら、次はC1から貼り付けたい
>> の意味が分りません。CSVデータは 2項目(2列)しかないのですか?
>
>の答えですが、CSVデータの列数は月ごとに変化してしまいます。
>なので、別シートに貼り付ける時、どこに貼るかあらかじめ指定ができないので空白列を見つけて貼り付けられるようにできないか、というイメージで書きました。

ということは、CSVファイル開いてみるまで、どういう項目が何列あるか、
分らないということですか?

それから
>CSVファイル1
>8/1 はなこ 東京都
>.
>.
>8/31 さえこ 埼玉
>
のようなCSVファイル例をみますと、1行目に項目名がないですけど?
項目名がないとフィルタかけられませんから、無いばあいはExcelで開いてから
ダミーの列見出しを挿入することになります。

あと、再度質問ですが、
CSVの項目数(列数)は都度変わるけれど、「日付」データは必ず A列固定と
考えていいですか? でないと、日付の列をマクロで探さないといけません。
それと、たとえば
8/31
の行はひとつのCSVに 複数行ありうるんですよね?

【74850】Re:複数のCSVファイルを開き、抽出、...
質問  マスク  - 13/9/29(日) 19:45 -

引用なし
パスワード
   宜しくお願いします。説明不足で申し訳ありません。

>もちろんマクロでAutoFilterをかけるわけです。
!なるほど。

>ということは、CSVファイル開いてみるまで、どういう項目が何列あるか、
分らないということですか?
その通りです。

>のようなCSVファイル例をみますと、1行目に項目名がないですけど?
項目名がないとフィルタかけられませんから、無いばあいはExcelで開いてから
ダミーの列見出しを挿入することになります。
CSVファイルには項目名がありません。
まず列見出しの挿入を考えなければならないのですね。なるほど。

>あと、再度質問ですが、
CSVの項目数(列数)は都度変わるけれど、「日付」データは必ず A列固定と
考えていいですか? でないと、日付の列をマクロで探さないといけません。
それと、たとえば
8/31
の行はひとつのCSVに 複数行ありうるんですよね?

CSVの列数は都度変わります。
日付データは必ずA列に存在します。日付だけは固定です。
8/31はひとつのCSVファイルに複数行必ず存在します。
営業時間内分のログが入っているので、数十行必ず存在します。


Sub prog4_2()
  dim myCri As String
  Dim myRow As Long
  Dim Sh2 As Worksheet, Sh3 As Worksheet
    Set Sh2 = Worksheets("データ")
    Set Sh3 = Worksheets("抽出")

    myCri = InputBox("日付を入力して下さい")

    With Sh2
      .Range("A1").AutoFilter Field:=1, Criteria1:=myCri
      myRow = .Range("A" & Rows.Count).End(xlUp).Row
      Sh3.Range("A:月によって変わる最終列").ClearContents

      .Range("A1:月によって変わる最終列" & myRow).Copy Sh3.Range("空白の列の1から貼るように")
      .Range("A1").AutoFilter
    End With
    Worksheets("抽出").Activate
    Range("A1").Select
End Sub

コメントを見て、似たような事例を引っ張ってきました。
やはり空白の列の求め方が分からないのと、貼りつける別シートは新規で作成したいのですが……。
ファイルを開いて見出し行を挿入する処理が分かりませんでした。
知識不足で申し訳ないです、宜しくお願いします。

【74851】Re:複数のCSVファイルを開き、抽出、...
質問  kanabun  - 13/9/29(日) 20:08 -

引用なし
パスワード
   ▼マスク さん:

>日付データは必ずA列に存在します。日付だけは固定です。
>8/31はひとつのCSVファイルに複数行必ず存在します。
>営業時間内分のログが入っているので、数十行必ず存在します。
了解です。

>コメントを見て、似たような事例を引っ張ってきました。
>やはり空白の列の求め方が分からないのと、貼りつける別シートは新規で作成したいのですが……。

>ファイルを開いて見出し行を挿入する処理が分かりませんでした。

とりあえず、CSVファイルの1行目が項目見出しになっている例で
考えてみました(そうのほうがAutoFilterすぐかけれて、単純なので)

Sub Filter_CSV()
  Dim myDate As Long '抽出したい日付 (シリアル値)
  Dim myCSVs, f
  Dim newBook As Workbook
  Dim rCopy As Range  '抽出転記先先頭セル
  Dim myCol As Long
    
  '●抽出したい日付をこのマクロブックのSheet1!A1セルに書いておく
  myDate = ThisWorkbook.Worksheets(1).Range("A1").Value2
  
  'OpenするCSVファイルを(複数)指定
  myCSVs = Application.GetOpenFilename("CSVファイル,*.csv", _
       MultiSelect:=True)
  If Not IsArray(myCSVs) Then Exit Sub
  
  '抽出転記先のBookを作成
  Set newBook = Workbooks.Add(xlWBATWorksheet) 'シート1枚
  Set rCopy = newBook.Sheets(1).Range("A1")
  
  '指定のCSVファイルを順に開いてフィルタ抽出
  For Each f In myCSVs
    With Workbooks.Open(f).Worksheets(1)
      '表領域に対してA列の日付をAutoFilterで抽出する
      With .Range("A1").CurrentRegion
        .AutoFilter 1, ">=" & myDate, xlAnd, "<=" & myDate
        If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
          myCol = .Columns.Count      '表の列数
          .Copy rCopy            '別シートにCopy
          Set rCopy = rCopy.Offset(, myCol) '次の貼り付け先
        End If
        .AutoFilter
      End With
      .Parent.Close False
    End With
  Next
  newBook.Close True
          
End Sub

これで 実際のCSVファイルの先頭に カンマ区切りで列見出しを書き込んで、
(ファイルは2つほどでよい)名前をつけて保存して、
↑のプロシージャを実行してみてください。

【74852】Re:複数のCSVファイルを開き、抽出、...
お礼  マスク  - 13/9/29(日) 21:23 -

引用なし
パスワード
   動いた……!

すみません、本当にありがとうございます!
完成シートを見て、感動しました!

まだ書いて頂いたコードがどう動いて、この動きが可能になっているのか
理解は出来てないのですが(一つ一つの関数の意味を調べてみます)
分かりやすい綺麗なコードを本当にありがとうございます。
まずオートフィルタで抽出すればいいということから理解できてない所、教えて頂きありがとうございました。

このようなコードが書けるよう知識を増やしていきたいと思います。
ご指導ありがとうございました!

【74854】Re:複数のCSVファイルを開き、抽出、...
発言  kanabun  - 13/9/30(月) 10:51 -

引用なし
パスワード
   ▼マスク さん:

>完成シートを見て、感動しました!

では、CSVに見出しがないときの処理を追加です。
Excelで開いたとき、[A1]セルが日付データだったら、一行挿入する
という処理を入れました。●の部分以降です。

Sub Filter_CSV2()
  Dim myDate As Long '抽出したい日付 (シリアル値)
  Dim myCSVs, f
  Dim newBook As Workbook
  Dim rCopy As Range  '抽出転記先先頭セル
  Dim myCol As Long
  Dim NoHeader As Boolean '見出しはあるか
  Dim i As Long
    
  '抽出したい日付をこのマクロブックのSheet1!A1セルに書いておく
  myDate = ThisWorkbook.Worksheets(1).Range("A1").Value2
  
  'OpenするCSVファイルを(複数)指定
  myCSVs = Application.GetOpenFilename("CSVファイル,*.csv", _
       MultiSelect:=True)
  If Not IsArray(myCSVs) Then Exit Sub
  
  '抽出転記先のBookを作成
  Set newBook = Workbooks.Add(xlWBATWorksheet) 'シート1枚
  Set rCopy = newBook.Sheets(1).Range("A1")  '最初の貼り付け先(セル)
  
  '指定のCSVファイルを順に開いてフィルタ抽出
  For Each f In myCSVs
    With Workbooks.Open(f).Worksheets(1)
      '表領域に対してA列の日付を抽出する
      With .Range("A1")
        myCol = .CurrentRegion.Columns.Count '表の列数
        NoHeader = IsDate(.Value) '●見出し行あり/なし
      End With
      If NoHeader Then '見出し行が無かったら
        '1行目に見出し行を挿入
        .Rows(1).Insert
        With .Rows(1).Cells
          For i = 1 To myCol
            .Item(i).Value = Chr$(&H40 + i) '仮の見出し
          Next
        End With
      End If
      '表領域に対してA列の日付を抽出する
      With .Range("A1").CurrentRegion
        .AutoFilter 1, ">=" & myDate, xlAnd, "<=" & myDate
        If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
          .Offset(1).Copy rCopy   '1行目は除外してコピー
          Set rCopy = rCopy.Offset(, myCol) '次の貼り付け先
        End If
        .AutoFilter
      End With
      .Parent.Close False '保存しないで閉じる
    End With
  Next
  newBook.Close True     '保存して閉じる
          
End Sub

>まずオートフィルタで抽出すればいいということから理解できてない

特定のアイテム行だけ抽出するために、フィルタを使うのですが、
今回のように 「日付のAutoFilter」は(文字列ではないので)ちょっと
気を付けないと抽出されません。
  
>  myCri = InputBox("日付を入力して下さい")
>
>    With Sh2
>      .Range("A1").AutoFilter Field:=1, Criteria1:=myCri

こういうフィルタのかけ方をすると、まず抽出されません。理由は Inputbox
関数の返り値が文字列だから、
  Criteria1:="8/31" という文字列の行を抽出しようとします。
正しく動くようにするには、Criteriaが数値になるようにします。
具体的には

  Criteria1:=">=" & 日付, xlAnd, Criteria2:="<=" & 日付

のように、不等号で抽出したい日付を挟んでやります。
そして、与える日付 は 2013/8/31 のような日付型でなく、
41517 のような シリアル値にすれば「完璧」です。
以上のようにすれば、A列の日付の表示形式がどのようなものであろうと、
必ず抽出されるはずです。

【74855】Re:複数のCSVファイルを開き、抽出、...
お礼  マスク  - 13/10/2(水) 21:55 -

引用なし
パスワード
   分かりやすい説明を何度も何度もありがとうございます。
Inputbox関数の返り値が文字列という説明には驚きました。
まだまだ知識不足を実感するばかりです。
本当にありがとうございました!!


▼kanabun さん:
>▼マスク さん:
>
>>完成シートを見て、感動しました!
>
>では、CSVに見出しがないときの処理を追加です。
>Excelで開いたとき、[A1]セルが日付データだったら、一行挿入する
>という処理を入れました。●の部分以降です。
>
>Sub Filter_CSV2()
>  Dim myDate As Long '抽出したい日付 (シリアル値)
>  Dim myCSVs, f
>  Dim newBook As Workbook
>  Dim rCopy As Range  '抽出転記先先頭セル
>  Dim myCol As Long
>  Dim NoHeader As Boolean '見出しはあるか
>  Dim i As Long
>    
>  '抽出したい日付をこのマクロブックのSheet1!A1セルに書いておく
>  myDate = ThisWorkbook.Worksheets(1).Range("A1").Value2
>  
>  'OpenするCSVファイルを(複数)指定
>  myCSVs = Application.GetOpenFilename("CSVファイル,*.csv", _
>       MultiSelect:=True)
>  If Not IsArray(myCSVs) Then Exit Sub
>  
>  '抽出転記先のBookを作成
>  Set newBook = Workbooks.Add(xlWBATWorksheet) 'シート1枚
>  Set rCopy = newBook.Sheets(1).Range("A1")  '最初の貼り付け先(セル)
>  
>  '指定のCSVファイルを順に開いてフィルタ抽出
>  For Each f In myCSVs
>    With Workbooks.Open(f).Worksheets(1)
>      '表領域に対してA列の日付を抽出する
>      With .Range("A1")
>        myCol = .CurrentRegion.Columns.Count '表の列数
>        NoHeader = IsDate(.Value) '●見出し行あり/なし
>      End With
>      If NoHeader Then '見出し行が無かったら
>        '1行目に見出し行を挿入
>        .Rows(1).Insert
>        With .Rows(1).Cells
>          For i = 1 To myCol
>            .Item(i).Value = Chr$(&H40 + i) '仮の見出し
>          Next
>        End With
>      End If
>      '表領域に対してA列の日付を抽出する
>      With .Range("A1").CurrentRegion
>        .AutoFilter 1, ">=" & myDate, xlAnd, "<=" & myDate
>        If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
>          .Offset(1).Copy rCopy   '1行目は除外してコピー
>          Set rCopy = rCopy.Offset(, myCol) '次の貼り付け先
>        End If
>        .AutoFilter
>      End With
>      .Parent.Close False '保存しないで閉じる
>    End With
>  Next
>  newBook.Close True     '保存して閉じる
>          
>End Sub
>
>>まずオートフィルタで抽出すればいいということから理解できてない
>
>特定のアイテム行だけ抽出するために、フィルタを使うのですが、
>今回のように 「日付のAutoFilter」は(文字列ではないので)ちょっと
>気を付けないと抽出されません。
>  
>>  myCri = InputBox("日付を入力して下さい")
>>
>>    With Sh2
>>      .Range("A1").AutoFilter Field:=1, Criteria1:=myCri
>
>こういうフィルタのかけ方をすると、まず抽出されません。理由は Inputbox
>関数の返り値が文字列だから、
>  Criteria1:="8/31" という文字列の行を抽出しようとします。
>正しく動くようにするには、Criteriaが数値になるようにします。
>具体的には
>
>  Criteria1:=">=" & 日付, xlAnd, Criteria2:="<=" & 日付
>
>のように、不等号で抽出したい日付を挟んでやります。
>そして、与える日付 は 2013/8/31 のような日付型でなく、
>41517 のような シリアル値にすれば「完璧」です。
>以上のようにすれば、A列の日付の表示形式がどのようなものであろうと、
>必ず抽出されるはずです。

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