stable

さえない大学生です

マクロメモ

Option Explicit
Sub CopyDataAndSaveNewWorkbook()
    Dim SourceFolder As String
    Dim SourceFile As String
    Dim NewWorkbook As Workbook
    Dim Pathtest As Object
    Dim Filename As String
    Dim wb As Workbook
    
    Set Pathtest = ThisWorkbook.ActiveSheet.Cells(2, 1) ' 指定のフォルダのパスを設定
    SourceFolder = Pathtest.Value ' フォルダのパスを変更
    
    Filename = Dir(SourceFolder & "*.xlsx")
    MsgBox "1" & SourceFolder
    MsgBox "2" & Filename
        Do While Filename <> ""
        
Dim WFna As String
WFna = Dir(SourceFolder & "*ABC.xlsx")
Workbooks.Open Filename:=SourceFolder & WFna

        ' ファイル名の末尾に「ABC」が含まれている場合にファイルを開く
'        If Right(Filename, 4) = "ABC" Then
'            Set wb = Workbooks.Open(SourceFolder & Filename)
            ' ここでファイルごとの処理を行うことができます
            ' 例: ファイルを開いた後、データの操作など

            ' ファイルを閉じる
'            wb.Close SaveChanges:=False
'        MsgBox "1" & SourceFolder
'        MsgBox "2" & Filename
'        Exit Do
'        End If
        Filename = Dir
        MsgBox "4" & Filename
    Loop
    MsgBox "3" & Filename
    
    ' フォルダ内の最新のExcelファイルを検索
'    SourceFile = Dir(SourceFolder & "*.xlsx")
 '   Do While SourceFile <> ""
'        If FileDateTime(SourceFolder & SourceFile) > FileDateTime(SourceFolder & SourceFile) Then
'            SourceFile = SourceFolder & SourceFile
'        End If
'        SourceFile = Dir
'    Loop
    
    MsgBox SourceFile
    Dim Awb As Workbook
    Set Awb = ActiveWorkbook
    Set NewWorkbook = Workbooks.Add
    ' データをコピー
    Awb.Worksheets(1).Range("A:J").Copy Awb.Worksheets(1).Range("A1")
    
    ' 最新のExcelファイルを開く
'    Workbooks.Open SourceFile
    Set Awb = ActiveWorkbook
    Awb.Worksheets("Sheet1").Range("A1").PasteSpecial
    
    ' 新しいブックに名前を付けて保存
    NewWorkbook.SaveAs "C:\Users\fafur\OneDrive\ドキュメント\excel練習\test\NewWorkbook.xlsx" ' 保存パスとファイル名を変更
    NewWorkbook.Close
End Sub