Option Explicit
Const フォルダパスの行数 = 3
Const 元の列数 = 2
Const コピー先の列数 = 3
Const 最初の行 = 6

Sub リネーム()
    
    Dim ws作業シート As Worksheet
    Set ws作業シート = ThisWorkbook.ActiveSheet
    
    Rem コピー先の指定がなければフォルダを作成
    If ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = "" Then
        MkDir ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
        ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
    End If
    
    Dim 最後の行 As Long
    最後の行 = ws作業シート.Cells(Rows.Count, 元の列数).End(xlUp).Row
    
    Rem コピー＆リネーム
    Dim f As Long
    For f = 最初の行 To 最後の行
        FileCopy ws作業シート.Cells(フォルダパスの行数, 元の列数).Value & "\" & ws作業シート.Cells(f, 元の列数).Value, _
                 ws作業シート.Cells(フォルダパスの行数, コピー先の列数).Value & "\" & ws作業シート.Cells(f, コピー先の列数).Value
    Next
    
    MsgBox "コピー＆リネーム完了！"
    
End Sub

• Like
• LINE
• Tweet
• Copy URL