Excel VBA質問箱 IV

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

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


6964 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【41737】複数ブックのデータを2条件により転記し...
質問  tanaka  - 06/8/21(月) 20:39 -

引用なし
パスワード
   同じフォルダ内に複数のファイルがあります。
それを別のひとつのファイルにデータをまとめていますが
「ふたつの条件に当てはまるファイルは転記しない」
という方法を教えてください。

複数ファイルのsheet1B1からB10のデータを転記するのですが

もし
1.各ファイルsheet1"A1"のNO.とsheet2"C1"のNO.が一致しない場合
(例)A1 は 234  と   C1 は 123
NO.が違うので転記しない

2.各sheet2"C1"から"P1"までのNO.かぶっている場合
(例)C1 123    
   D1 234  
   E1 567 
   P1 123
C1とP1は数字がかぶっているのでこのファイルは転記しない  

また最後に転記しなかったファイル名をMSGBOXで出したいのです。 

どういう風に書けばよいのでしょうか?
ご指導宜しくお願い致します。

【41740】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/21(月) 21:53 -

引用なし
パスワード
   ▼tanaka さん:
こんばんは。

Sheet1のA1、Sheet2のC1〜P1には、必ず数値が入っているという
前提で・・・・、

標準モジュールに
'=============================================================
Sub main()
  Dim nomvarray() As String
  Dim nomvcnt 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
  nomvcnt = 0
  foldnm = "D:\My Documents\TESTエリア\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)
         If Evaluate("SUM(COUNTIF(" & add & "," & add & "))") = .Count Then
           MsgBox bk.Name & " 転記処理を行う"
           '    実際は、ここで転記処理を行う
           ret = 0
           End If
         End With
        End If
      If ret <> 0 Then
        ReDim Preserve nomvarray(1 To nomvcnt + 1)
        nomvarray(nomvcnt + 1) = .Name
        nomvcnt = nomvcnt + 1
        End If
      .Close False
      End With
     End If
    Next
  If nomvcnt > 0 Then
    MsgBox "転記しなかったブックは、" & vbCrLf & vbCrLf & Join(nomvarray(), vbCrLf)
    End If
  Set fls = Nothing
  Set fl = Nothing
End Sub
どのように転記するのかわかりませんが、
条件チェックは上記のような処理で可能です。

検討してみてください。

【41752】Re:複数ブックのデータを2条件により転...
回答  Kein  - 06/8/22(火) 0:45 -

引用なし
パスワード
   マクロを実行するブックの Sheet1 を、判定のための作業シート
とします。まとめのブックはマクロ実行ブックと同じフォルダーに、
日付入りのブック名で保存します。データを入力している複数ブック
の保存先フォルダーを定数で宣言し、それを仮に C:\temp とします。
転記先の表は、A2以下A列にブック名を & その行のC列から10列右までに
B1:B10のデータを行列変換して表示します。
>転記しなかったファイル名をMSGBOXで
ファイル数が多いと表示しきれないおそれがあるので、イミディエイト
ウィンドウに出力します。

以上の条件で

Sub MyData_Summary()
  Dim Ans As Integer, Snum As Integer
  Dim Sh As Worksheet
  Dim WB As Workbook
  Dim MyF As String, LkS As String, Fname As String
  Dim CkV As Variant
  Dim Flg As Boolean
  Const Ph As String = "C:\temp\"

  Fname = ThisWorkbook.Path & "\Summary" & Year(Date) & _
  "_" & Month(Date) & "_" & Day(Date) & ".xls"
  If Dir(Fname) <> "" Then
   Ans = MsgBox("既に本日分の処理済みブックが保存されています" & _
   vbLf & "保存しているブックを破棄し新たに転記処理しますか", 36)
   If Ans = 6 Then
     Kill Fname
   Else
     Exit Sub
   End If
  End If
  With Application
   Snum = .SheetsInNewWorkBook
   .SheetsInNewWorkBook = 1
   .ScreenUpdating = False
  End With
  Set Sh = ThisWorkbook.Worksheets("Sheet1")
  MyF = Dir(Ph & "*.xls")
  If MyF = "" Then
   MsgBox "保存されているブックが見つかりません", 48
   GoTo ELine
  Else
   Set WB = Workbooks.Add
  End If
  Do Until MyF = ""
   Sh.Range("1:2").ClearContents
   LkS = "='" & Ph & "[" & MyF & "]"
   Sh.Range("A1").Formula = LkS & "Sheet1'!$A$1"
   Sh.Range("B1").Formula = LkS & "Sheet2'!$C$1"
   Sh.Range("C1:P1").Formula = LkS & "Sheet2'!C$1"
   Sh.Range("A1:P1").Value = Sh.Range("A1:P1").Value
   Sh.Range("B2").Formula = "=IF($A$1<>$B$1,""中止"",0)"
   Sh.Range("C2:P2").Formula = _
   "=IF(COUNTIF($C$1:$P$1,C$1)>1,""中止"",0)"
   CkV = Application.Match("中止", Sh.Rows(2), 0)
   If IsError(CkV) Then
     With Sh.Range("AA1:AA10")
      .Formula = LkS & "Sheet1'!$B1"
      .Copy
     End With
     With WB.Worksheets(1).Range("A65536").End(xlUp)
      .Offset(1).Value = MyF
      .Offset(1, 2).PasteSpecial xlPasteValues, , , True
     End With
     Sh.Range("AA1:AA10").ClearContents
     Application.CutCopyMode = False
   Else
     Flg = True: Debug.Print MyF
   End If    
   MyF = Dir()
  Loop
  WB.Worksheets(1).Range("A1").Select
  WB.Close True, Fname: Set WB = Nothing
ELine:
  Set Sh = Nothing
  With Application
   .SheetsInNewWorkBook = Snum
   .ScreenUpdating = True
  End With
  If Flg Then
   With Application.VBE.MainWindow
     .Visible = True
     .SetFocus
   End With
   SendKeys "^(g)", True
  End If
End Sub

【41788】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/22(火) 21:25 -

引用なし
パスワード
   ▼ichinose さん:

ご丁寧にありがとうございます。
初歩的な質問かもしれませんが、
フォルダ内の各ファイルの容量が大きいと


>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(fl.Path)

getfolderではファイルを認知してもらえないものなのでしょうか?
といいますのも
ファイルの場所を確認してくださいというエラーが出るのです。
サンプルで簡単なフォルダファイルを作ってやってみると
うまく作動したので・・・
あるいは何か考えられることがあるのでしょうか。
ご教授お願い致します。

【41789】Re:複数ブックのデータを2条件により転...
お礼  tanaka  - 06/8/22(火) 21:48 -

引用なし
パスワード
   keinさん
ご丁寧にありがとうございます。
やってみます!

【41791】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/22(火) 22:13 -

引用なし
パスワード
   ▼tanaka さん:
こんばんは。
>初歩的な質問かもしれませんが、
>フォルダ内の各ファイルの容量が大きいと
容量による違いがあるとは考えられませんが・・・。
>
>
>>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(fl.Path)
>


>getfolderではファイルを認知してもらえないものなのでしょうか?
>といいますのも
>ファイルの場所を確認してくださいというエラーが出るのです。

エラー発生時のフォルダ名(foldnmに指定した文字列)を
教えてください。

>サンプルで簡単なフォルダファイルを作ってやってみると
>うまく作動したので・・・
>あるいは何か考えられることがあるのでしょうか。
>ご教授お願い致します。

【41793】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/22(火) 22:40 -

引用なし
パスワード
   ▼ichinose さん

>こんばんは。
>>初歩的な質問かもしれませんが、
>>フォルダ内の各ファイルの容量が大きいと
>容量による違いがあるとは考えられませんが・・・。
勝手な見解で言ってしまいました。すみません。
>>
>>>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(fl.Path)
デバッグでここ↑が黄色になります。

>
>>getfolderではファイルを認知してもらえないものなのでしょうか?
>>といいますのも
>>ファイルの場所を確認してくださいというエラーが出るのです。
>
>エラー発生時のフォルダ名(foldnmに指定した文字列)を
>教えてください。
>
foldnm="\\sst\商品管理\担当別\商品一覧表"です。

保存先がちがうのですが、okだったのは

foldnm="C:\Documents and Settings\tanaka\My Documents\集計表\練習"
でした。

宜しくお願い致します。

【41796】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/23(水) 8:02 -

引用なし
パスワード
   ▼tanaka さん:
おはようございます。

>>>>Set fls = CreateObject("scripting.filesystemobject").GetFolder
>>>>(foldnm).Files
>>>>  For Each fl In fls
>>>>    If UCase(fl.Name) Like UCase("*.xls") Then
>>>>     ret = 1
       debug.print fl.Path
'とすれば、エラーになったときのブック名がイミディエイトウインドウにて
'確認できます この名前のブックが手動で開くことができますか?
'
'
>>>>     Set bk = Workbooks.Open(fl.Path)
>デバッグでここ↑が黄色になります。
'エラー発生時の正確なエラーメッセージとエラー番号も記述してください
>
>>
>>>getfolderではファイルを認知してもらえないものなのでしょうか?
>>>といいますのも
>>>ファイルの場所を確認してくださいというエラーが出るのです。
>>
>>エラー発生時のフォルダ名(foldnmに指定した文字列)を
>>教えてください。
>>
>foldnm="\\sst\商品管理\担当別\商品一覧表"です。
FSOは、UNCパスでも問題はないとおもいますが・・・。
上記の点を確認してみてください

【41836】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/23(水) 22:00 -

引用なし
パスワード
   お手数かけてます。ありがとうございます。
正確なエラー文をメモって帰っていないので
また来させていただきます。
実行時のエラー番号は1004で
"\\sst\商品管理\担当別\商品一覧表\八王子.xls"のファイルが見つかりません。
ファイルの場所を確認してください。
という感じの文章だったと思いますが・・・。


次いで、しまって申し訳ないのですが
転記できなかったファイル名は条件別に分けることはできますでしょうか?

下記のブックは転記できませんでした。
1.A1とC1のNO.が一致していません  
新宿.xls
大阪北.xls
2.NO.が重複しています  
京都.xls
北海道.xls

という感じに。。。

何かヒントをいただけませんでしょうか。
宜しくお願い致します。

【41849】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/24(木) 8:17 -

引用なし
パスワード
   ▼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\TESTエリア\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

上記の変更で可能だと思います。

【41877】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/24(木) 21:03 -

引用なし
パスワード
   こんにちは。ありがとうございます。
エラーメッセージは
「実行時エラー'1004'
'\\sst\??-\担当別\商品一覧表\八王子.xlsが見つかりません。ファイル名および
ファイルの保存場所が正しいかどうか確認してください。
[ファイル]メニューの使用ファイルの一覧からファイルを開こうとしている場合は
そのファイルの名前が変更されていないこと、移動または削除されていないことを
確認してください。」
でした。

イミディエイトウインドウで、ファイル名を表示してみたところ
\\sst\??-\担当別\商品一覧表\八王子.xls と
商品管理のところが??-になっていましたし、
ブックは開きませんでした。
ブックを一つに指定するとうまくいきました。

今excel2002を使用しているのですが
FSOには関係有りますか?

表題と質問がずれてきてしまって申し訳ないので
Dir関数の使用を考えてみます。

【41890】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/25(金) 7:34 -

引用なし
パスワード
   ▼tanaka さん:
おはようございます。
再現ができないので対処法が私にはわかりませんが、

>エラーメッセージは
>「実行時エラー'1004'
>'\\sst\??-\担当別\商品一覧表\八王子.xlsが見つかりません。ファイル名および
>ファイルの保存場所が正しいかどうか確認してください。
Fl.Pathで正しくパスが取得できていないという事ですね!!

因みに以下のコードではどうでしょうか?
'==========================================================
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\TESTエリア\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(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)
         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

これでうまくいってしまうと、ますます現象の原因はわからなくなってしまいますが。

試してみてください。

【42004】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/28(月) 21:58 -

引用なし
パスワード
   こんにちは。
ありがとうございます。
workbooks.open(foldnm & "\" & fl.name)で
うまくいきました!

動いて質問が出てしまいました。
メッセージが何回も出てきます。
フォルダ内に八王子.xls、広島.xls、福岡.xls、北海道.xlsがあるとき

八王子.xls
「mes1」
 ↓
広島.xls
「転記処理を行う」
 ↓
八王子.xls
「mes1」
 ↓
八王子.xls
「mes1」
福岡.xls
「mes2」
 ↓
八王子.xls
北海道.xls
「mes1」
福岡xls
「mes2」

のようなメッセージが連なります。
まとまっっている最後のメッセージだけを表示とできるでしょうか?
なかなかうまく応用できずお手数掛けて申し訳有りません。
宜しくお願いいたします。

【42005】Re:複数ブックのデータを2条件により転...
発言  ichinose  - 06/8/28(月) 22:20 -

引用なし
パスワード
   ▼tanaka さん:
こんばんは。

>ありがとうございます。
>workbooks.open(foldnm & "\" & fl.name)で
>うまくいきました!
う〜ん、どうしてでしょうねえ!!

>
>動いて質問が出てしまいました。
>メッセージが何回も出てきます。
>フォルダ内に八王子.xls、広島.xls、福岡.xls、北海道.xlsがあるとき
>
>八王子.xls
>「mes1」
> ↓
>広島.xls
>「転記処理を行う」
> ↓
>八王子.xls
>「mes1」
> ↓
>八王子.xls
>「mes1」
>福岡.xls
>「mes2」
> ↓
>八王子.xls
>北海道.xls
>「mes1」
>福岡xls
>「mes2」

コードを見せてください。

[#41890] の私のコードの

foldnm = "D:\My Documents\TESTエリア\testarea2002\testfold"

のフォルダ名を変更しただけですか?

【42022】Re:複数ブックのデータを2条件により転...
発言  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

【42059】Re:複数ブックのデータを2条件により転...
発言  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構文の使い方に間違いがありませんか?
再度確認してください。

【42069】Re:複数ブックのデータを2条件により転...
発言  tanaka  - 06/8/30(水) 23:16 -

引用なし
パスワード
   こんにちは。
毎回ありがとうございます。

ファイルと結果を照らし合わせながらの作業を続けていますが
今のところ、きちんと希望通りに分けて転記しています。
メッセージが何回も出るのはまだ解決していませんが
ちょこっとづつ変えたりしながらチャレンジしています。

元に書いていただいたコードはあまり変えていないはずなんですが
どこかおかしくなってるところがあるんですね。。
withのところということですが。。
このコードでは動かない・・ということでしょうか?

【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も逐次表示することもありませんでした。

確認してください。

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