Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

39816 / 76732

←次へ　｜　前へ→


	【42022】Re:複数ブックのデータを２条件により転記しない方法

tanaka - 06/8/29(火) 21:36 -


	引用なし

	パスワード

こんにちは。
ありがとうございます。

foldnmのフォルダ名は変えていません。
set bk=Workbooks.Open(foldnm & "\" & fl.name)のカッコ内を変えました。
あとは考えていただいた通りです。
宜しくお願い致します。

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 & vbcLrf & "　転記処理を行います。"
　　　　　　　　　
　　　　　　　　　 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) = .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
　　Set num =Nothing
End Sub

1 hits

▼

【41737】複数ブックのデータを２条件により転記しない方法 tanaka 06/8/21(月) 20:39