Excel VBA質問箱 IV

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

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


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

39786 / 76738

←次へ　｜　前へ→


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

ichinose - 06/8/30(水) 18:55 -


	引用なし

	パスワード

▼tanaka さん：
>こんにちは。
>ありがとうございます。
>
>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
このコード正しく動いていますか？
With構文の使い方に間違いがありませんか？
再度確認してください。

0 hits

▼

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