Excel VBA質問箱 IV

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

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


39764 / 76732 ←次へ | 前へ→

【42076】Re:複数ブックのデータを2条件により転記しない方法
発言  ichinose  - 06/8/31(木) 7:43 -

引用なし
パスワード
   ▼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も逐次表示することもありませんでした。

確認してください。
0 hits

【41737】複数ブックのデータを2条件により転記しない方法 tanaka 06/8/21(月) 20:39 質問
【41740】Re:複数ブックのデータを2条件により転記... ichinose 06/8/21(月) 21:53 発言
【41788】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 21:25 発言
【41791】Re:複数ブックのデータを2条件により転記... ichinose 06/8/22(火) 22:13 発言
【41793】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 22:40 発言
【41796】Re:複数ブックのデータを2条件により転記... ichinose 06/8/23(水) 8:02 発言
【41836】Re:複数ブックのデータを2条件により転記... tanaka 06/8/23(水) 22:00 発言
【41849】Re:複数ブックのデータを2条件により転記... ichinose 06/8/24(木) 8:17 発言
【41877】Re:複数ブックのデータを2条件により転記... tanaka 06/8/24(木) 21:03 発言
【41890】Re:複数ブックのデータを2条件により転記... ichinose 06/8/25(金) 7:34 発言
【42004】Re:複数ブックのデータを2条件により転記... tanaka 06/8/28(月) 21:58 発言
【42005】Re:複数ブックのデータを2条件により転記... ichinose 06/8/28(月) 22:20 発言
【42022】Re:複数ブックのデータを2条件により転記... tanaka 06/8/29(火) 21:36 発言
【42059】Re:複数ブックのデータを2条件により転記... ichinose 06/8/30(水) 18:55 発言
【42069】Re:複数ブックのデータを2条件により転記... tanaka 06/8/30(水) 23:16 発言
【42076】Re:複数ブックのデータを2条件により転記... ichinose 06/8/31(木) 7:43 発言
【41752】Re:複数ブックのデータを2条件により転記... Kein 06/8/22(火) 0:45 回答
【41789】Re:複数ブックのデータを2条件により転記... tanaka 06/8/22(火) 21:48 お礼

39764 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free