複数シート名とブック名が一致する場合内容を転記 VBA

Question

VBA初心者です。
自分で組んでみたのですが上手く動作せず、質問させていただきます。

元データの各シート名が複数ブック名と一部一致する場合
一致したブックに新しいシートを追加して、元データのシート内容を転記していきたいです。

フォルダ内に元データとなるブックと転記したい複数ブックが格納されている状態です。
元データには各拠点の名前で複数シートが存在します。
複数のブック名は”拠点名【営業活動個人分析】”となっています。


現状はシートの追加まで組んでいるつもりです。※下記添付


どこをどう直せばいいのか、もしくは別の方法があれば教えて頂けると幸いです。


Sub consolid()
    'このブックと同じフォルダの全ブックをまとめます
    Dim mb As Workbook
    Dim wb As Workbook
    Dim myfdr As String
    Dim fname As String
    Dim n As Long
    Dim i As Integer
    
    Application.ScreenUpdating = False
    Set mb = ThisWorkbook
    myfdr = ThisWorkbook.path
    fname = Dir(myfdr & "\*営業活動個人分析*.xls*")
    Do Until fname = Empty
        If fname <> mb.Name Then
           Set wb = Workbooks.Open(myfdr & "\" & fname)
     i = 1
    Do While i <= Worksheets.Count
     
           Dim str1 As String
    
    str1 = "【"
    
      If Left(wb.Name, InStr(wb.Name, str1) - 1) = mb.Worksheets(i).Name Then
      
      
       Dim s As Variant, flag As Boolean

   Dim ws As Worksheet
   Dim ws1 As Worksheet

Set ws1 = mb.Worksheets

For Each s In Sheets
If s.Name = ws1.Cells(1, "AO").Value Then
 flag = True
            Exit For
        End If
        Next s
        If flag = False Then
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = ws1.Cells(1, "AO").Value
End If
End If
      
      
       Loop
      
           wb.Close
           
           
           n = n + 1
        End If
        fname = Dir
    Loop
    
    
    
    Application.ScreenUpdating = True
    
End Sub

tatsumaru77 · Accepted Answer

とりあえず動くようにしました。
ブック名は横浜【個人分析管理表】ではなく横浜【営業活動個人分析管理表】にしてあります。どちらが正しいかは、こちらでは判断できません。
横浜【個人分析管理表】が正しいなら
fname = Dir(myfdr & "\*営業活動個人分析*.xls*")
を
fname = Dir(myfdr & "\*個人分析*.xls*")
にしてください。
-------------------------------------
Sub consolid()
'このブックと同じフォルダの全ブックをまとめます
    Dim mb As Workbook
    Dim wb As Workbook
    Dim myfdr As String
    Dim fname As String
    Dim i As Integer
    Application.ScreenUpdating = False
    Set mb = ThisWorkbook
    myfdr = ThisWorkbook.Path
    fname = Dir(myfdr & "\*営業活動個人分析*.xls*")
    Do Until fname = Empty
        If fname <> mb.Name Then
            Set wb = Workbooks.Open(myfdr & "\" & fname)
            i = 1
            Do While i <= mb.Worksheets.Count
                Dim str1 As String
                str1 = "【"
                If Left(wb.Name, InStr(wb.Name, str1) - 1) = mb.Worksheets(i).Name Then
                    Dim s As Worksheet, flag As Boolean
                    Dim ws As Worksheet
                    Dim ws1 As Worksheet
                    flag = False
                    Set ws1 = mb.Worksheets(i)
                    For Each s In wb.Worksheets
                        If s.Name = ws1.Cells(1, "AO").Value Then
                            flag = True
                            Exit For
                        End If
                    Next s
                    If flag = False Then
                        Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
                        ws.Name = ws1.Cells(1, "AO").Value
                    End If
                End If
                i = i + 1
            Loop
            wb.Close (True)
        End If
        fname = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

tatsumaru77 · Answer

補足要求です。
１．元データの各シート名が複数ブック名と一部一致する場合ということですが、シート名のサンプルとブック名のサンプルを提示してください。
また、そのどこが一致すると転記条件が成立すのかを例を提示してください。
２．シートを追加する条件を日本語で説明してください。
（AO１のセルの内容も含めて）

めぐみん_ · Answer

気になった点。

＞Do While i <= Worksheets.Count

のシートカウントって
・このコードが記載されているＢｏｏｋ
・直前に開かれたアクティブなＢｏｏｋ
のどちらを指しているのでしょう？

と初級レベルは思いました。

どちらに対してもSetステートメントを用いるのなら、Ｂｏｏｋを明確に指定する方がミスる事はないと思いますけど。

＞ flag As Boolean

フラグを立てループ内で幾度も使用するなら、

＞flag = True

で処理を抜けループの最初に戻った際には、flag = False による初期設定が必要なのでは？

fujillin · Answer

こんにちは

ざっと眺めただけなので、よく理解できていませんが…

＞元データのシート内容を転記していきたいです。
なんだか、値を転記している部分が見当たらないような気がしますが…？

＞元データには各拠点の名前で複数シートが存在します。
同じ名前のシートが複数存在できないので、実態はどうなっているのかしらん。

既に指摘が出ていますが…
＞Do While i <= Worksheets.Count
＞For Each s In Sheets
＞Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
複数のブックを扱う場合、デフォルトの指定を利用しない方が間違いを防ぎやすいと思います。

そもそもですが…
＞上手く動作せず、質問させていただきます。
「何が思ったのと違うのか」、「実際にやりたいことは何か」をキチンと説明しないで、コードのみを示しても、コードが動作する限りは「それが質問者様のなさりたいこと」という解釈の前提でしか読み取れません。
ですので、第三者には「動けばＯＫ」という判断でしか回答できないと思いますよ。

さて、現状は二重のループで、合致を検索しているように見受けられますが、想像するところ、「元データ」というブック内の各シートを処理できれば良いのではないでしょうか？
フォルダ内の各ブックに対応するシートが必ず存在するのかは不明ですが、現状ではフォルダ内のブックを全て必要あろうが/なかろうが開いているので、時間のロスがありそうに思えます。

一方で、元ブックのシート名がわかれば転記先のブック名は決まるのでしょうから、元ブックのシートに対してループさせるようにすれば、処理全体は一重のループで済むものと推測します。

よくわかっていませんけれど…
シート名に対して、
　「元ブックのシート名」&「【営業活動個人分析】.xls」
というファイルを開いて転記するような手順にした方が、流れがわかりやすくなるのではないかと想像しました。

ついでながら、余計なことではありますが、デバッグ中は
＞Application.ScreenUpdating = False
などは外しておいた方が、処理の動きがある程度は目視可能なので宜しいのでは？
（画面がチラついたり、実行速度は遅くなりますけれど）

※ なさりたいことをほとんど理解できていませんので、的外れかもしれませんが、その際にはご容赦ください。

めぐみん_ · Answer

No.2です。

＞＞flag = False
＞一応記載はしているのですが、書く位置が違いますかね；

老眼のせいか Next の位置を勘違いしてたみたいです。
スル～しちゃって下さい。

複数シート名とブック名が一致する場合内容を転記 VBA

補足要求です。

気になった点。

こんにちは

No.2です。

とりあえず動くようにしました。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング