特定フォルダー内のファイルから特定のシートの指定列データを選択し、別のファイルに転記

投稿者 : ふくふく     投稿日時 : 2025/04/09(Wed) 17:07:44     OS : Windows 11     EXCEL : Office 365

---

特定フォルダー内のファイルから特定のシートの指定列データを選択し、別のファイルに転記をしたいのですが
転記が出来ません。

step実行で確認しましたが、原因がわかりません。
ファイルを開いていないような気もするのですが…。

ご教授いただければ幸いです。

Sub 転記マクロ()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim filePath As String
    Dim fileName As String
    Dim destinationWorkbook As Workbook
    Dim destinationSheet As Worksheet
    Dim LastRow As Long
    Dim columnToCopy As Integer
    Dim folderPath As String
    
    '転記先のブックを開く
    Set destinationWorkbook = ThisWorkbook                                    'このマクロがあるファイルを「転記先」とする
    Set destinationSheet = destinationWorkbook.Sheets("転記")      '転記先のシート名を指定

    'ファイルダイアログを開いてフォルダを選択
    folderPath = Application.FileDialog(msoFileDialogFolderPicker).Show
    
    If folderPath = "" Then
        MsgBox "フォルダが選択されませんでした。"
        Exit Sub
    End If

    'フォルダ内の各Excelファイルを確認
    fileName = Dir(folderPath & "\*.xlsx")

    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & "\" & fileName)        'ファイルを開く
        
        '特定のシートを選択
        Set ws = wb.Sheets("R0703")         '転記したいシートの名前を指定

        '転記先の最終行を取得
        LastRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row + 1

        '特定の列のデータを転記（例えば列A列のデータを転記なら１）
        columnToCopy = 3            '転記したい列の番号
        destinationSheet.Cells(LastRow, 1).Value = ws.Cells(5, columnToCopy).Value          '1行目のデータを転記
        
        wb.Close False 'ファイルを保存せずに閉じる
        fileName = Dir() '次のファイルへ
    Loop

    MsgBox "転記が完了しました。"
End Sub

投稿者 : さんこう     投稿日時 : 2025/04/09(Wed) 17:25:06

---

＞step実行で確認しましたが、原因がわかりません。
＞ファイルを開いていないような気もするのですが…。

Step実行すれば明らかですが、フォルダ名を取得できていないようです。

「Application.FileDialog(msoFileDialogFolderPicker)」の使い方を確認してみてはいかがでしょうか。


＜FileDialog(msoFileDialogFolderPicker)＞
https://www.google.com/search?q=FileDialog(msoFileDialogFolderPicker)

投稿者 : jindon     投稿日時 : 2025/04/10(Thu) 14:06:53

---

シート名と抽出セルアドレスが確定しているのであれば、こんな方法も...

Sub test()
    Dim myDir$, fn$, s$(1), x
    Const wsName$ = "R0703"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    s(0) = "'" & myDir & "\[#]" & wsName & "'!r5c3"
    fn = Dir(myDir & "*.xls*")
    Do While fn <> ""
        s(1) = Replace(s(0), "#", fn)
        s(1) = "if(" & s(1) & "<>""""," & s(1) & ","""")"
        x = ExecuteExcel4Macro(s(1))
        If Not IsError(x) Then
            Sheets("転記").Range("a" & Rows.Count).End(xlUp)(2).Resize(, 2) = Array(x, fn)
        End If
        fn = Dir
    Loop
End Sub

投稿者 : higeru     投稿日時 : 2025/04/10(Thu) 14:44:50

---

■[質問] ふくふくさん（2025-04-09 17:07:44）の記事
＞ 特定フォルダー内のファイルから特定のシートの指定列データを選択し、別のファイルに転記をしたいのですが
＞ 転記が出来ません。
＞
＞ step実行で確認しましたが、原因がわかりません。


　失礼ながら Step 実行させて何を見ているのですかね。

folderPath = Application.FileDialog(msoFileDialogFolderPicker).Show

を実行したところで folderPath にマウスポインタを合わせるなりローカルウィンドウを見るなりして値を確認してください。

投稿者 : ふくふく     投稿日時 : 2025/04/12(Sat) 10:47:19

---

さんこうさん、higeruさん、助言ありがとうございます。
また、jindonさんには、別解のコード案ありがとうございます。

下記の部分を修正しました。

'ファイルダイアログを開いてフォルダを選択
folderPath = Application.FileDialog(msoFileDialogFolderPicker).Show

　　　　　　　　↓
'ファイルダイアログを開いてフォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
FolderPath = .SelectedItems(1)
End With

ファイルが開き、転記することが出来ました。
しかしこのコードでは転記データが１セルのみで、列全体を取得する事が出来ません。

ご教授お願い致します。

投稿者 : さんこう     投稿日時 : 2025/04/12(Sat) 11:33:12

---

＞しかしこのコードでは転記データが１セルのみで、列全体を取得する事が出来ません。

どこのデータを、どこへ転記するのかわかりませんが、参考になれば。

＜vba 転記 別シート 列＞
https://www.google.com/search?q=vba+%E8%BB%A2%E8%A8%98+%E5%88%A5%E3%82%B7%E3%83%BC%E3%83%88+%E5%88%97

投稿者 : ふくふく     投稿日時 : 2025/04/15(Tue) 13:06:44

---

さんこうさん　ありがとうございます。

やってみます。