| |
▼tanaka さん：
こんばんは。
Sheet1のＡ１、Sheet2のＣ１〜Ｐ１には、必ず数値が入っているという
前提で・・・・、
標準モジュールに
'=============================================================
Sub main()
Dim nomvarray() As String
Dim nomvcnt As Long
Dim fls As Object
Dim ret As Long
Dim foldnm As String
Dim fl As Object
Dim add As String
Dim bk As Workbook
nomvcnt = 0
foldnm = "D:\My Documents\ＴＥＳＴエリア\testarea2002\testfold"
' 実際に検査するフォルダ名 ↑
Set fls = CreateObject("scripting.filesystemobject").GetFolder(foldnm).Files
For Each fl In fls
If UCase(fl.Name) Like UCase("*.xls") Then
'↑指定フォルダ内にあるExcelブックだったら？
ret = 1
Set bk = Workbooks.Open(fl.Path)
With bk
If .Worksheets("sheet1").Range("a1").Value = .Worksheets("sheet2").Range("c1").Value Then
With .Worksheets("sheet2").Range("c1:p1")
add = .Address(, , , True)
If Evaluate("SUM(COUNTIF(" & add & "," & add & "))") = .Count Then
MsgBox bk.Name & " 転記処理を行う"
' 実際は、ここで転記処理を行う
ret = 0
End If
End With
End If
If ret <> 0 Then
ReDim Preserve nomvarray(1 To nomvcnt + 1)
nomvarray(nomvcnt + 1) = .Name
nomvcnt = nomvcnt + 1
End If
.Close False
End With
End If
Next
If nomvcnt > 0 Then
MsgBox "転記しなかったブックは、" & vbCrLf & vbCrLf & Join(nomvarray(), vbCrLf)
End If
Set fls = Nothing
Set fl = Nothing
End Sub
どのように転記するのかわかりませんが、
条件チェックは上記のような処理で可能です。
検討してみてください。
|
|
ichinose
- 06/8/21(月) 21:53 -
