| |
▼tanaka さん：
おはようございます。
>メッセージが何回も出るのはまだ解決していませんが
これも不思議？？、Msgbox関数の記述って何箇所も記述していませんよね？
FSOの動作も最初に申し上げたとおり私は経験したことがないのですが、
さらに [#42022] で投稿されたコードがとりあえず作動していることも？？？です。
tanaka さんが提示されたコードをフォルダ名やシート名だけを私の環境に合わせて
変更したものを実行すると「Elseに対するIfがありません」という
コンパイルエラーが発生して実行はされません。
こういうエラーの場合は対になっている構文の何かが抜けている場合がほとんどの
原因になっていますし、tanaka さんのコードには確かに抜けている箇所があります。
私もExcel2002（Sp-3）&Win2000で確認しています。
tanaka さんが提示されたコードが何とかエラーで停止することなしに
動作させるには、
'======================================================================
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 num As Range
Dim LRow As Long
ThisWorkbook.Worksheets("売上").Range("A1:Y65536").ClearContents
nomvcnt1 = 0: nomvcnt2 = 0
foldnm = "\\sst\商品管理\担当別"
Set fls = CreateObject("scripting.filesystemobject").GetFolder(foldnm).Files
For Each fl In fls
If UCase(fl.Name) Like UCase("*.xls") Then
ret = 1
Set bk = Workbooks.Open(foldnm & "\" & fl.Name)
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 & vbCrLf & " 転記処理を行います。"
' Vbcrlfの訂正
Set num = bk.Worksheets("担当").Range("L4")
num.Copy
With ThisWorkbook.Worksheets("売上")
LRow = .Range("A65536").End(xlUp).Row
If LRow = 1 Then
.Range("A" & LRow).PasteSpecial xlPasteValues
Else
.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End If
End With
Else
ReDim Preserve nomvarray2(1 To nomvcnt2 + 1)
nomvarray2(nomvcnt2 + 1) = bk.Name
' ↑bk.nameと訂正
nomvcnt2 = nomvcnt2 + 1
End If
End With '*** このEnd With を追加
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
Set num = Nothing
End Sub
このように訂正するととりあえずエラーなしで動作しましたし、
Msgboxも逐次表示することもありませんでした。
確認してください。
|
|
ichinose
- 06/8/31(木) 7:43 -
