ExcelVBA　フォルダすべてのExcel　特定のシートの特定のセルから特定の文字列を検索してその何個か右のセルまでをコピーして特定のセルにペーストする　　ChatGPTとCopilotを使いながら

ChatGPTもありますがCopilotも良いかも知れません。

Excelで数が多いときはExcelVBAの方が動きが速いです、Power Automate Desktopに比べれば。

なので今回はExcelVBAです。

ChatGPTにExcelVBAを聞いて

起動しないです。なぜでしょうね。

そのなぜを解明するのに時間がかかるようでは帰って、手でやった方がいいのではないかと思えて来ます。

起動しない理由を考えるのは骨が折れます。

もう諦めようと考えたときにふと、CopilotもAIなので相談に乗ってくれるかと考え

似たような質問（タイトル）のような質問を投げて見ました。

CopilotにExcelVBAを聞いて

Sub ProcessAllExcelsInFolder()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    ' フォルダパスを指定します。
    folderPath = "C:\path\to\your\folder" ' ここを適切なパスに変更してください。
    
    ' フォルダ内のすべてのExcelファイルを処理します。
    fileName = Dir(folderPath & "\*.xls*")
    Do While fileName <> ""
        ' ワークブックを開きます。
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        
        ' 2番目のワークシートを選択します。
        Set ws = wb.Worksheets(2)
        
        ' "合計"の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。
        Set rng = ws.Range("C12").End(xlToRight).End(xlToRight)
        rng.Copy
        
        ' B12セルにペーストします。
        ws.Range("B12").PasteSpecial Paste:=xlPasteAll
        
        ' ワークブックを保存して閉じます。
        wb.Close SaveChanges:=True
        
        ' 次のファイルを処理します。
        fileName = Dir
    Loop
End Sub

実行すると、C14がコピペされました。

ありがとう。 “合計”の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。 ここは、C12セルから合計という文字列が入ったセルの２つの右のセルを１列の範囲でこぴーしてほしい。 今はC12の２つ右のセルになっているよ。

加えて

バランス良く→厳密に変更して質問しました。

その結果

Sub ProcessAllExcelsInFolder()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' フォルダパスを指定します。
    folderPath = "C:\path\to\your\folder" ' ここを適切なパスに変更してください。
    
    ' フォルダ内のすべてのExcelファイルを処理します。
    fileName = Dir(folderPath & "\*.xls*")
    Do While fileName <> ""
        ' ワークブックを開きます。
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        
        ' 2番目のワークシートを選択します。
        Set ws = wb.Worksheets(2)
        
        ' "合計"の文字列が入ったセルを探します。
        For Each cell In ws.Range("C12:C1048576")
            If cell.Value = "合計" Then
                ' "合計"の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。
                Set rng = ws.Range(cell, cell.Offset(0, 2))
                rng.Copy
                
                ' B12セルにペーストします。
                ws.Range("B12").PasteSpecial Paste:=xlPasteAll
                
                ' ワークブックを保存して閉じます。
                wb.Close SaveChanges:=True
                
                ' 次のファイルを処理します。
                fileName = Dir
                
                Exit Sub
            End If
        Next cell
    Loop
End Sub

実行すると画面が固まりました。

C1048576は合計という文字列の２つ右の変数という意味になっているのかな。

いえ、”C1048576″はExcelのセルのアドレスを指しています。Excelのワークシートには、行が1から1048576まで、列がAからXFDまであります。したがって、”C1048576″は、C列の最後の行、つまり1048576行目を指します。

このコードの中で、”C12:C1048576″は、C列の12行目から最後の行までの範囲を示しています。この範囲内で”合計”という文字列が入ったセルを探し、そのセルから2つ右のセルまでの範囲をコピーします。

したがって、”C1048576″は”合計”という文字列の2つ右の変数を意味しているわけではありません。ご理解いただけますでしょうか。

理解しました。 ただ、それなら私の伝え方が悪かったです。 “C12:C1048576″の範囲に合計という文字列はいません。A列の中にいます。 それを踏まえて、VBAコードを再作成お願いしたいです。

ご指摘いただきありがとうございます。A列に”合計”という文字列があるとのこと、理解しました。その情報を考慮に入れて、以下のようにVBAコードを修正しました。

Sub ProcessAllExcelsInFolder()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' フォルダパスを指定します。
    folderPath = "C:\path\to\your\folder" ' ここを適切なパスに変更してください。
    
    ' フォルダ内のすべてのExcelファイルを処理します。
    fileName = Dir(folderPath & "\*.xls*")
    Do While fileName <> ""
        ' ワークブックを開きます。
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        
        ' 2番目のワークシートを選択します。
        Set ws = wb.Worksheets(2)
        
        ' A列で"合計"の文字列が入ったセルを探します。
        For Each cell In ws.Range("A1:A1048576")
            If cell.Value = "合計" Then
                ' "合計"の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。
                Set rng = ws.Range(cell, cell.Offset(0, 2))
                rng.Copy
                
                ' B12セルにペーストします。
                ws.Range("B12").PasteSpecial Paste:=xlPasteAll
                
                ' ワークブックを保存して閉じます。
                wb.Close SaveChanges:=True
                
                ' 次のファイルを処理します。
                fileName = Dir
                
                Exit Sub
            End If
        Next cell
    Loop
End Sub

ありがとう。惜しいです。 “合計”の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。 Set rng = ws.Range(cell, cell.Offset(0, 2)) rng.Copy ここはC12から “合計”の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。 以上の内容に変更できれば完璧です。

ご指摘いただきありがとうございます。”C12″から”合計”という文字列が入ったセルから2つ右のセルまでの範囲をコピーするように、以下のようにVBAコードを修正しました。

Sub ProcessAllExcelsInFolder()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' フォルダパスを指定します。
    folderPath = "C:\path\to\your\folder" ' ここを適切なパスに変更してください。
    
    ' フォルダ内のすべてのExcelファイルを処理します。
    fileName = Dir(folderPath & "\*.xls*")
    Do While fileName <> ""
        ' ワークブックを開きます。
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        
        ' 2番目のワークシートを選択します。
        Set ws = wb.Worksheets(2)
        
        ' A列で"合計"の文字列が入ったセルを探します。
        For Each cell In ws.Range("A1:A1048576")
            If cell.Value = "合計" Then
                ' "C12"から"合計"の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。
                Set rng = ws.Range("C12", cell.Offset(0, 2))
                rng.Copy
                
                ' B12セルにペーストします。
                ws.Range("B12").PasteSpecial Paste:=xlPasteAll
                
                ' ワークブックを保存して閉じます。
                wb.Close SaveChanges:=True
                
                ' 次のファイルを処理します。
                fileName = Dir
                
                Exit Sub
            End If
        Next cell
    Loop
End Sub

実行で完成を確認しました。

しかし、繰り返しがうまくいかず一つのファイルしか実行されません。

あなたのコードが繰り返し処理を行わない理由は、Exit SubステートメントがIf cell.Value = "合計"の条件内にあるためです。このステートメントは、Subプロシージャを終了し、制御を呼び出し元のプロシージャに戻します。したがって、”合計”という値を持つ最初のセルを見つけた後、プロシージャは終了し、ループは次のファイルに移動しません。

この問題を解決するためには、Exit Subステートメントを削除するか、適切な場所に移動させる必要があります。以下に修正したコードを示します：

Sub ProcessAllExcelsInFolder()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' フォルダパスを指定します。
    folderPath = "C:\path\to\your\folder" ' ここを適切なパスに変更してください。
    
    ' フォルダ内のすべてのExcelファイルを処理します。
    fileName = Dir(folderPath & "\*.xls*")
    Do While fileName <> ""
        ' ワークブックを開きます。
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        
        ' 2番目のワークシートを選択します。
        Set ws = wb.Worksheets(2)
        
        ' A列で"合計"の文字列が入ったセルを探します。
        For Each cell In ws.Range("A1:A1048576")
            If cell.Value = "合計" Then
                ' "C12"から"合計"の文字列が入ったセルから2つ右のセルまでの範囲をコピーします。
                Set rng = ws.Range("C12", cell.Offset(0, 2))
                rng.Copy
                
                ' B12セルにペーストします。
                ws.Range("B12").PasteSpecial Paste:=xlPasteAll
                
                ' ワークブックを保存して閉じます。
                wb.Close SaveChanges:=True
                
                ' 次のファイルを処理します。
                Exit For
            End If
        Next cell
        
        fileName = Dir
    Loop
End Sub

この修正により、各Excelファイルが正しく処理され、”合計”という値を持つセルが見つかった場合にはそのファイルの処理が終了し、次のファイルに移動します。Exit Forステートメントは、現在のForループを終了し、制御をForステートメントの直後に移動します。これにより、各ファイルが正しく処理されます。この修正があなたの問題を解決することを願っています。もし他に質問があれば、お気軽にどうぞ。よろしくお願いいたします。🙂

成果物までつながればどちらでもいいのです

途中コード作成を諦めかけました。

2時間かけたけど、無駄だったかと。

ChatGPTが難しければ、Copilotでいいんです。無料で利用していてなんですが

成果につながればどちらでもいいです。

今回成果に繋がったのは、抽象的に言えば、2つ選択肢があったのが良かったです。

１つしかなくてそれがダメだと大変困りますし、立ち止まってしまいます。

どちらもダメだったらまあ難しいことだったのだろうと諦め、より詳しい専門家に聞くようにしたでしょう。

２つ以上手段を持って冷静になれるようにしておきましょう。

成果が出て成功体験を積んで行けば、事案が増えるのであのときのあのようにやればいけるかもしれないと

前向きにチャレンジできますよ。

｛今日のオフ｝

歯のメインテナンス

---

 

■プロフィール

■WEB開催セミナー4/20：2025　歯科クリニック開業で伝えたいこと

■開業したいドクター向けの動画販売

■開業ドクターを支援する士業等向けの動画販売

■相続相談

■社長向け（税務顧問・セカンドオピニオン）

---