Excel VBA質問箱 IV

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

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


40090 / 76738 ←次へ | 前へ→

【41752】Re:複数ブックのデータを2条件により転記しない方法
回答  Kein  - 06/8/22(火) 0:45 -

引用なし
パスワード
   マクロを実行するブックの Sheet1 を、判定のための作業シート
とします。まとめのブックはマクロ実行ブックと同じフォルダーに、
日付入りのブック名で保存します。データを入力している複数ブック
の保存先フォルダーを定数で宣言し、それを仮に C:\temp とします。
転記先の表は、A2以下A列にブック名を & その行のC列から10列右までに
B1:B10のデータを行列変換して表示します。
>転記しなかったファイル名をMSGBOXで
ファイル数が多いと表示しきれないおそれがあるので、イミディエイト
ウィンドウに出力します。

以上の条件で

Sub MyData_Summary()
  Dim Ans As Integer, Snum As Integer
  Dim Sh As Worksheet
  Dim WB As Workbook
  Dim MyF As String, LkS As String, Fname As String
  Dim CkV As Variant
  Dim Flg As Boolean
  Const Ph As String = "C:\temp\"

  Fname = ThisWorkbook.Path & "\Summary" & Year(Date) & _
  "_" & Month(Date) & "_" & Day(Date) & ".xls"
  If Dir(Fname) <> "" Then
   Ans = MsgBox("既に本日分の処理済みブックが保存されています" & _
   vbLf & "保存しているブックを破棄し新たに転記処理しますか", 36)
   If Ans = 6 Then
     Kill Fname
   Else
     Exit Sub
   End If
  End If
  With Application
   Snum = .SheetsInNewWorkBook
   .SheetsInNewWorkBook = 1
   .ScreenUpdating = False
  End With
  Set Sh = ThisWorkbook.Worksheets("Sheet1")
  MyF = Dir(Ph & "*.xls")
  If MyF = "" Then
   MsgBox "保存されているブックが見つかりません", 48
   GoTo ELine
  Else
   Set WB = Workbooks.Add
  End If
  Do Until MyF = ""
   Sh.Range("1:2").ClearContents
   LkS = "='" & Ph & "[" & MyF & "]"
   Sh.Range("A1").Formula = LkS & "Sheet1'!$A$1"
   Sh.Range("B1").Formula = LkS & "Sheet2'!$C$1"
   Sh.Range("C1:P1").Formula = LkS & "Sheet2'!C$1"
   Sh.Range("A1:P1").Value = Sh.Range("A1:P1").Value
   Sh.Range("B2").Formula = "=IF($A$1<>$B$1,""中止"",0)"
   Sh.Range("C2:P2").Formula = _
   "=IF(COUNTIF($C$1:$P$1,C$1)>1,""中止"",0)"
   CkV = Application.Match("中止", Sh.Rows(2), 0)
   If IsError(CkV) Then
     With Sh.Range("AA1:AA10")
      .Formula = LkS & "Sheet1'!$B1"
      .Copy
     End With
     With WB.Worksheets(1).Range("A65536").End(xlUp)
      .Offset(1).Value = MyF
      .Offset(1, 2).PasteSpecial xlPasteValues, , , True
     End With
     Sh.Range("AA1:AA10").ClearContents
     Application.CutCopyMode = False
   Else
     Flg = True: Debug.Print MyF
   End If    
   MyF = Dir()
  Loop
  WB.Worksheets(1).Range("A1").Select
  WB.Close True, Fname: Set WB = Nothing
ELine:
  Set Sh = Nothing
  With Application
   .SheetsInNewWorkBook = Snum
   .ScreenUpdating = True
  End With
  If Flg Then
   With Application.VBE.MainWindow
     .Visible = True
     .SetFocus
   End With
   SendKeys "^(g)", True
  End If
End Sub

0 hits

【41737】複数ブックのデータを2条件により転記しない方法 tanaka 06/8/21(月) 20:39 質問
【41740】Re:複数ブックのデータを2条件により転記... ichinose 06/8/21(月) 21:53 発言
【41788】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 21:25 発言
【41791】Re:複数ブックのデータを2条件により転記... ichinose 06/8/22(火) 22:13 発言
【41793】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 22:40 発言
【41796】Re:複数ブックのデータを2条件により転記... ichinose 06/8/23(水) 8:02 発言
【41836】Re:複数ブックのデータを2条件により転記... tanaka 06/8/23(水) 22:00 発言
【41849】Re:複数ブックのデータを2条件により転記... ichinose 06/8/24(木) 8:17 発言
【41877】Re:複数ブックのデータを2条件により転記... tanaka 06/8/24(木) 21:03 発言
【41890】Re:複数ブックのデータを2条件により転記... ichinose 06/8/25(金) 7:34 発言
【42004】Re:複数ブックのデータを2条件により転記... tanaka 06/8/28(月) 21:58 発言
【42005】Re:複数ブックのデータを2条件により転記... ichinose 06/8/28(月) 22:20 発言
【42022】Re:複数ブックのデータを2条件により転記... tanaka 06/8/29(火) 21:36 発言
【42059】Re:複数ブックのデータを2条件により転記... ichinose 06/8/30(水) 18:55 発言
【42069】Re:複数ブックのデータを2条件により転記... tanaka 06/8/30(水) 23:16 発言
【42076】Re:複数ブックのデータを2条件により転記... ichinose 06/8/31(木) 7:43 発言
【41752】Re:複数ブックのデータを2条件により転記... Kein 06/8/22(火) 0:45 回答
【41789】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 21:48 お礼

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