| |
▼tanaka さん：
おはようございます。
>実行時のエラー番号は1004で
>"\\sst\商品管理\担当別\商品一覧表\八王子.xls"のファイルが見つかりません。
手動操作でこのブックが開くことができるかも確認してください。
>ファイルの場所を確認してください。
>という感じの文章だったと思いますが・・・。
>
>
>次いで、しまって申し訳ないのですが
>転記できなかったファイル名は条件別に分けることはできますでしょうか？
>
>下記のブックは転記できませんでした。
>1.A1とC1のNO.が一致していません
>新宿.xls
>大阪北.xls
>2.NO．が重複しています
>京都.xls
>北海道.xls
>
これは、
'======================================================================
Sub main()
Dim nomvarray1() As String
Dim nomvarray2() As String
Dim nomvcnt1 As Long
Dim nomvcnt2 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
Dim mes1 As String
Dim mes2 As String
Dim rcnt As Long
nomvcnt1 = 0: nomvcnt2 = 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)
rcnt = .Count
End With
If Evaluate("SUM(COUNTIF(" & add & "," & add & "))") = rcnt Then
MsgBox bk.Name & " 転記処理を行う"
' 実際は、ここで転記処理を行う
Else
ReDim Preserve nomvarray2(1 To nomvcnt2 + 1)
nomvarray2(nomvcnt2 + 1) = .Name
nomvcnt2 = nomvcnt2 + 1
End If
Else
ReDim Preserve nomvarray1(1 To nomvcnt1 + 1)
nomvarray1(nomvcnt1 + 1) = .Name
nomvcnt1 = nomvcnt1 + 1
End If
.Close False
End With
End If
Next
If nomvcnt1 > 0 Or nomvcnt2 > 0 Then
If nomvcnt1 > 0 Then
mes1 = "1.A1とC1のNO.が一致していません" & vbCrLf & Join(nomvarray2(), vbCrLf)
End If
If nomvcnt2 > 0 Then
mes2 = "2.NO．が重複しています" & vbCrLf & Join(nomvarray1(), vbCrLf)
End If
MsgBox "転記しなかったブックは、" & vbCrLf & vbCrLf & mes1 & vbCrLf & vbCrLf & mes2
End If
Set fls = Nothing
Set fl = Nothing
End Sub
上記の変更で可能だと思います。
|
|
ichinose
- 06/8/24(木) 8:17 -
