| |
マクロを実行するブックの 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
|
|
Kein
- 06/8/22(火) 0:45 -
