Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7全般 : Excel 2010)
複数のブックを抽出して ひとつのブックにまとめる方法
投稿日時: 18/11/29 11:21:37
投稿者: chokobanana

マクロ初心者です。
検索で似たようなマクロを参考に途中まで作ってたのですが 動かなくなってしまいました。
もう一度 最初から作る気力もなく。。。どなたか知識のある方 教えて頂けないでしょうか。
 
【やりたいこと】
・複数のブックに入力されているデータを期間で抽出し、他のブックに貼りつけたいのです。
 
文字にすると1行なのですが イメージは、
 
@コマンドボタンAをクリックすると抽出を入力するフォーム(抽出)が開く。
Aフォーム(抽出)に抽出期間(日付と時間)を入力し、コマンドBをクリックすると複数のブック(C)のデー
タを抽出する。
   1.フォーム(抽出)のコマンドボタンB以外にコマンドE(キャンセル)もあります。
   2.抽出期間は日付と時間、例えば11/20の10:30〜11/25の16:30までという形にしたいです。
   3.複数のブック(C)は10個程度(数は将来増える可能性有)、全て同じ様式、シートはひとつのみで     す。
B抽出結果のH列に「○」をつける。
   4.抽出結果が無い場合もあります。
Cブック(D)の一一番右にシートを追加し、名前を今日の日付にする。
   5.ブック(D)も複数のブック(C)と同じフォルダに入ってます。
Dブック(D)の追加したシートに抽出結果を貼りつける。
   6.抽出結果のA列からG列までを貼りつけます。
E抽出結果がなければCで作成のシートを削除して、「抽出できるデータはありません。」とメッセージボックスが出る。
 
マクロ初心者なので説明が分かりにくい場合はスイマセン。
全部できるマクロはハードルが高いので複数のマクロを作ってつなげようと思ってます。
下記にマクロを貼りつけておきます。
 
【困っていること】
A ・期間抽出で条件が日付も時間もというのが分かりません。
  ・テキストの入力文字数が少ない場合のエラーの出し方が分かりません。
  ・複数ブック(C)とブック(D)の場所は変更になる可能性があるので、どこでも動作ができるようにし    たいです。(今はアドレス?をコードに入力してます。)
B ・抽出結果に「〇」がつかないです。  
C ・追加したシートに枝番をつけたいです。
D ・抽出結果をブック(D)にコピーすると複数ブック(C)の分の見出しがコピーされます。
  ・抽出結果をA列〜G列を貼りつけた後にH列に罫線で外枠を作ることはできるのでしょうか。
Eは作成できてません(@〜Dがまだまだなので。。。)
 
長々となってスイマセンが教えて頂けないでしょうか。
よろしく お願いいたします。
 
≪ブックの様式≫
『複数ブック(C)』
    [A]  [B]  [C]・・・[H]
[10]  a@ 日付   時間    判定 
[11]  1  11/25   11:15   〇
 
≪@のマクロ≫ ⇒動作良好
Private Sub 作成ボタン_Click()
 
 uf.Show  ⇒ufはフォーム抽出のことです。
End Sub
 
Aのマクロ
 ≪コマンドBをクリック≫ ⇒まだ日付のテキストとキャンセルの場合は作成できてません。
Private Sub cmd1_Click()
 
If tx1.Text = "" Then
  MsgBox "開始日を入力してください。"
  Exit Sub
 End If
 
If tx2.Text = "" Then
  MsgBox "終了日を入力してください。"
  Exit Sub
 End If
  
 Call シート作成  ⇒Cを行うマクロです。 
 Call 結合     ⇒複数のブック(C)を抽出し、「〇」をつけて、ブック(D)に貼りつけるマクロです。
  
 End Sub
 
≪シート作成のマクロ≫
Sub シート作成()
 
Dim ws1 As Worksheet ⇒ws1はブック(D)です。
Dim i As Integer
 
 Rows("10:10").Select ⇒抽出結果を貼りつける時、見出が複数になったのでRow(10:10)に見出しを
 Selection.Copy     作って、それを毎回コピーしてます。(不細工です。。。)
 
 Set ws1 = Sheets.Add(After:=Sheets(Sheets.Count))
 ws1.Name = Format(Date, "yyyymmdd")  ⇒同じ日に何度か作業するので、日付に枝番をつけていのですが
                     上手くいきません。
 Rows("10:10").Select
 Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=False
   
 ActiveSheet.Paste
 Application.CutCopyMode = False
 
End Sub
 
≪結合のマクロ≫ ⇒ここが一番悩みの種です。作動しなくなりました。
Sub 結合()
 
Const Fol As String = "C:\●●" ⇒ 場所が変わる可能性があるので、都度入力しなくてすむようにした
                   いです。
Dim fN
Dim Wb As Workbook 
Dim wB2 As Workbook 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet
Dim 開始日 As Date
Dim 終了日 As Date
Dim R As Range
 
Set wB2 = ThisWorkbook  ⇒ブック(D)です。
Set ws1 = ActiveSheet   ⇒ブック(D)のシート作成マクロで追加したsheetです。
Set R = ws1.Range("A11")
fN = Dir(Fol, vbNormal)
Do Until fN = ""
Set Wb = Workbooks.Open(Fol & fN)
'ワークシート1をコピーする場合は Wb.Worksheets(1)
Set ws2 = Wb.Worksheets(1)  ⇒複数のブック(C)のsheetです。
 
  開始日 = uf.tx1.Value  ⇒ufは抽出期間を入力するフォームです。今はまだ時間を作ってないです。
  終了日 = uf.tx2.Value   txはそれぞれ日付を入力するテキストボックスです。
   
    ws2.Range("A11").AutoFilter Field:=2, _  ⇒A10は見出し、A11からデータがあります。
    Criteria1:=">=" & 開始日, _
    Operator:=xlAnd, _
    Criteria2:="<=" & 終了日
     
    For Each c In ws2.Columns(1).SpecialCells(xlCellTypeVisible) ⇒可視セル?をつかもうとした??
 
    If c = "" Then
     Exit Sub
    End If
     
   Range("H" & c.Row) = "〇" ⇒複数ブック(D)の抽出結果のH列に「○」をつけたい。
  Next c
  
 ws2.Range("A11", ws2.Cells(Rows.Count, 1).End(xlUp)).Resize(, 8).Copy R ⇒抽出結果を貼りつけ。
 Set R = R.End(xlDown).Offset(1)                      見出しが全部貼りつけ                                       れるので、ひとつだけに
  ws2.Range("A11").AutoFilter ⇒抽出を戻す。                したいです。
 
If R.Offset(1).Value = "" Then
 Set R = R.Offset(1)
 Else
 Set R = R.End(xlDown).Offset(1)
  
 End If
  
Wb.Close False
 
'Debug.Print Fn
fN = Dir
Loop
 
Set R = Nothing
Set ws1 = Nothing: Set ws2 = Nothing
Set Wb = Nothing: Set NewFile = Nothing
 
End Sub
 
 
 
 
  
 
 
 
 
 
 
 
 
 
 

回答
投稿日時: 18/11/29 17:08:11
投稿者: WinArrow
投稿者のウェブサイトに移動

とりあえず

引用:
【困っていること】
A ・期間抽出で条件が日付も時間もというのが分かりません。
   ・テキストの入力文字数が少ない場合のエラーの出し方が分かりません。
   ・複数ブック(C)とブック(D)の場所は変更になる可能性があるので、どこでも動作ができるようにし    たいです。(今はアドレス?をコードに入力してます。)
B ・抽出結果に「〇」がつかないです。  
C ・追加したシートに枝番をつけたいです。
D ・抽出結果をブック(D)にコピーすると複数ブック(C)の分の見出しがコピーされます。
   ・抽出結果をA列〜G列を貼りつけた後にH列に罫線で外枠を作ることはできるのでしょうか。

について、コメント
 
Aブック(C)のシートに「日付」と「時間」が別々のセルなので
テキストボックスも別々に用意したほうが分かりやすいし、
入力値の妥当性チェックを簡単になると思います。
なお、セルの「日付」には、「年」が含まれていると思いますので、
テキストボックスも「年」を入力するようにするべきです。
 
ブックのパスについて
コードの中に記述するのではなく、マクロブックとの相対位置で指定できるように考えましょう。
 
B抽出結果の件
> Range("H" & c.Row) = "〇" ⇒複数ブック(D)の抽出結果のH列に「○」をつけたい。
このコードで代入しているシートはどちらのシートですか?
 
Cシート名の枝番
 シート名 = Format(NOW(),"yyyymmddhhmm")
 にして、時分までのシート名にすれば簡単では?
 
Dここで、問題はなに?
 
 
番外
 
(1)処理の順序
シートを作成した後で、抽出していますが、逆に考えて
抽出件数があった場合にシートを作成すればよいでしょう。
結合プロシジャの中から、「シート作成」を呼び出せばよいでしょう。
 
 
 
 
 

回答
投稿日時: 18/11/29 17:38:13
投稿者: WinArrow
投稿者のウェブサイトに移動

追加レス
  
コードをわかりやすくするように工夫しましょう
  

>Set wB2 = ThisWorkbook  ⇒ブック(D)です。
>Set ws1 = ActiveSheet   ⇒ブック(D)のシート作成マクロで追加したsheetです。
  
ws2をブック(C)側のシートで使われています。
WB2 =ブック(D)ならば、ws2もブック(D)側
  
ws1はブック(C)側のシート
  
という具合です。
  
 
>ws2.Range("A11").AutoFilter Field:=2, _  ⇒A10は見出し、A11からデータがあります。
オートフィルタは、見出し行を指定します。

ws2.Range("A10").AutoFilter Field:=2, _
 
 
 > For Each c In ws2.Columns(1).SpecialCells(xlCellTypeVisible) ⇒可視セル?をつかもうとした??
 可視セルを取得しる方法でOKですすが、
Columns(1)ではなく、A10〜データの最終行です。
 抽出件数なしは、
If C = "" ではありません。
 見出し行があるから、C.Value = Range("A11").Value です。
 

回答
投稿日時: 18/11/29 17:39:49
投稿者: WinArrow
投稿者のウェブサイトに移動

追加の訂正
 
> 見出し行があるから、C.Value = Range("A11").Value です。

 見出し行があるから、C.Value = Range("A10").Value にした方がよいでしょう。

回答
投稿日時: 18/11/29 17:43:38
投稿者: Suzu

こんにちは。
 

chokobanana さんの引用:
マクロ初心者です。
検索で似たようなマクロを参考に途中まで作ってたのですが 動かなくなってしまいました。
もう一度 最初から作る気力もなく。。。どなたか知識のある方 教えて頂けないでしょうか。

 
この出だしで始まって、途中のコードをつらつらと並べられたら
やる気ないから、コードちょうだい と読めてしまい、回答を見送る気になってしまいます。
 
 
引用:
・期間抽出で条件が日付も時間もというのが分かりません。

 
少なくとも2列に渡って評価しないといけません。
条件として 11/20の10:30〜11/25の16:30 だとして、
 
ID	日付	時刻
1	11/19	10:40
2	11/20	10:10
3	11/20	11:00
4	11/20	16:45
5	11/21	09:30
6	11/21	10:45
7	11/21	17:00

 
だとすれば、3〜7 のデータが対象となります。
 
しかし、
単に、
日付の抽出条件、で期間 11/20〜11/25
時刻の抽出条件、で期間 10:30〜16:30
を指定すると
得られる結果は、3、5のみであり、4、6 はが抜けてしまいます。
 
これは、条件二つ共に 合致する場合のみの結果しか得る事ができないからです。
 
簡単なのは、作業列を作ります。
 
I列にでも、日付と、時刻の列の足し算の計算結果を得られる列を作ります。
I11 : =B11+C11
という事です。
 
この列に対し、2018/11/20 10:30 〜 2018/11/25 16:30 の条件を指定します。
 
こうなると、3〜6 を得る事ができます。
 
マクロの書かれているブック を ワークブックA
      抽出条件を指定する ワークシートを シート0
 
データのあるワークブックを ワークブックB
      そのうち、元のワークシート を シート1
      新しく作成するワークシート を シート2
 
とします。
 
Sub Macro1()
  Dim wbk0 As Workbook, wbk1 As Workbook
  Dim wst0 As Worksheet, wst1 As Worksheet, wst2 As Worksheet

  Dim i As Long, j As Long
  Dim strDate As String

  Set wbk0 = ThisWorkbook
  Set wst0 = wbk0.Worksheets("シート0")

  Set wbk1 = Workbooks("ワークブックB.xlsx")
  Set wst1 = wbk1.Worksheets("シート1")

  i = 0: j = 0

  'シート1 の最終行取得
  '(A10アクティブセルにし、End+↓にて得られる最終行を取得)
  i = wst1.Range("A10").End(xlDown).Row

  '日付取得
  strDate = Format(Date, "yyyymmdd")

  'ワークシート名の同じ日付の最大値を取得
  For Each wst2 In wbk1.Worksheets
    If wst2.Name Like strDate & "*" Then
      If Len(wst2.Name) > 6 Then
        If j < CLng(Mid(wst2.Name, 7)) Then
          j = CLng(Mid(wst2.Name, 7))
        End If
      End If
    End If
  Next

  'シート1 作業列を作成
  wst1.Range("I10") = "日時"
  wst1.Range("I11").FormulaLocal = "=B11+C11"
  wst1.Range("I11").AutoFill wst1.Range("I11:I" & i), xlFillCopy

  'シート2追加
  Set wst2 = wbk1.Worksheets.Add(After:=wbk1.Worksheets(wbk1.Worksheets.Count))
  wst2.Name = strDate & Format(j + 1, "000")

  '念の為オートフィルターが掛かっていたら解除
  If wst1.FilterMode Then wst1.Range("A10:I" & i).AutoFilter

  wst1.Range("A10:I" & i).AutoFilter _
        Field:=9, _
        Criteria1:=">=2018/11/25 12:00", _
        Operator:=xlAnd, _
        Criteria2:="<=2018/11/30 12:00"

  'H列のオートフィルター範囲の項目名行以降に○代入
  wst1.AutoFilter.Range.Offset(1, 0). _
    Resize(wst1.AutoFilter.Range.Rows.Count - 1, wst1.AutoFilter.Range.Columns.Count). _
    Columns("H").Value = "○"

  'wst2にコピー
  wst1.AutoFilter.Range.Copy wst2.Range("A10")

  'オートフィルター解除
  wst1.Range("A10:I" & i).AutoFilter
End Sub

投稿日時: 18/11/30 09:39:54
投稿者: chokobanana

WinArrowさん
 
返信ありがとうございます。
 
Aテキストボックスですが指摘どおり日付用と時間用を作成し、日付用は年から入力するようにフォームにコメントをいれました。
別々の場合、テキストボックスを日付と時間どうつなげるのかわからなかったのですが、相対位置(?)を使えば大丈夫なんですね。
勉強して、コードを練り直してみます。
 
B判りにくい説明でスイマセン。
代入しているシートはws2です。
 
C秒は考えたのですが見づらいとの指摘があったので、枝番ができればと思ってのです。
"yyyymmdd_#"だと枝番にならなくって。。。頑張って調べてみます。
 
D判りにくい説明でスイマセン。
抽出結果のみをコピーをしたいのですがA10(見出し)からコピーされてしまいます。
この解決方法が分からないのです。。。
 
【例】
   (A)  (B)  (C)
(1) a@  日付  氏名   ⇒見出し
(2) a@  日付  氏名   ⇒見出し
(3) 1   11/25  田中
(4) a@  日付  氏名   ⇒見出し
(5) 1   11/16  鈴木
(6) 2   11/17  鈴木 
 
番外
逆に考える!!
そんな発想はなかったです。
ありがとうございます。
 
丁寧なコメントありがとうございます。
とても分かりやすかったです。
ご指摘の事項を勉強して作り直そうと思います。
 
ほんとにありがとうございます。

投稿日時: 18/11/30 09:55:43
投稿者: chokobanana

Suzuさん
 
返信ありがとうございます。
 
スイマセン。
丁寧な説明ありがとうございます。
 
頂いたコードの意味をまだ理解できていないので調べてみようと思います。
 
取り急ぎ ご連絡差し上げます。
また、解決しましたら ご報告します。
 
ホントにありがとうございます

回答
投稿日時: 18/11/30 16:12:58
投稿者: WinArrow
投稿者のウェブサイトに移動

オートフィルタで抽出したセル範囲から、見出し行を除いて複写する方法
 
ヒント
Dim CELL1 As Range, CELL2 As Range
    With Sheets("Sheet1")
        Set CELL1 = .AutoFilter.Range
        Set CELL2 = .AutoFilter.Range.Offset(1)
        Application.Intersect(CELL1, CELL2).Copy Sheets("Sheet2").Range("A1")
    End With

投稿日時: 18/12/01 09:07:05
投稿者: chokobanana

WinArrowさん
 
返信ありがとうございます。
 
理解するのに時間がかかってしまい、返信が遅くなりました。
あと少しだと思うので頑張ってみます。
 
【やりたいこと】
@ ⇒ 完成
A ⇒ 完成
B ⇒ あと少し
    『○』が保存されません。
C ⇒ あと少し
D ⇒ あと少し
    抽出結果を貼りつけるとH列以降もコピーされてしまいます。
    貼りつけ後に削除するしか方法はないのでしょうか?
    それと、結果が無い場合bェ全てコピーされてしまいました。
E ⇒ あと少し
    処理の順序でマクロが動かなくなってしまいました(汗)
    Do Loopでエラーが出るようになってりまいました。
    入れる場所がおかしいのでしょうか?
    
    
    fN = Dir(Fol, vbNormal)
    Do Until fN = ""
    ・画面を停止
    ・複数ブックを開く
    ・複数ブックのフィルタを解除
          ↓
     If Dに入力がある場合
          ↓
    ・フィルタ
    ・結果に『○』をつける
    ・コピー貼り付け
          ↓
    Else
     Msgbox"抽出はありません。"
    End If
          ↓
    Application.DisplayAlerts = False
    Workbooks("Book1.xls*").Save
    Workbooks("Book1.xls*").Close
    Application.ScreenUpdating = True
  
    Wb1.Close False
 
    fN = Dir
    Loop
 
    ・SetがなければEnd Sub

トピックに返信