www.smiyasaka.com  は、2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。
● Excel マクロの解説 「 コピー名前変更マクロ 」編 ● 4 2,349 2   

「 コピー名前変更マクロ 」について、簡単ですが赤字で解説を入れました。
参考になれば、幸いです。

H26.06.12 現在
------------------ ここから ThisWorkBook コード -----------------------
ブックを閉じた時に、アドインを消去する。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Reset
    B02リセット
End Sub
---------------------------------------------------------------------------------
ブックを開いた時に、アドインを表示する。
Private Sub Workbook_Open()
    Application.CommandBars("Cell").Controls(1).BeginGroup = True
    B01セット
End Sub
-------------------  ここから UForm20のコード ------------------------
[読込み先パス設定]ボタンクリックでブック読込先のディレクトリーを
設定する。
Private Sub CommandButton1_Click()
    フォルダ参照 SFolda
    If SFolda = "" Then Exit Sub            <----  フォルダの指定が無い時は、
                                                                                   強制終了する。
    読込側のフォルダのパス設定を「マクロの表紙」に保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value = SFolda
End Sub
---------------------------------------------------------------------------------
[書込み先パス設定]ボタンクリックで写真書込み先のディレクトリーを
設定する。
Private Sub CommandButton2_Click()
    フォルダ参照 SFolda
    If SFolda = "" Then Exit Sub            <----  フォルダの指定が無い時は、
                                                                                   強制終了する。
    書込み先側のフォルダのパス設定を「マクロの表紙」に保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value = SFolda
End Sub
---------------------------------------------------------------------------------
[写真名抽出]ボタンクリックで指定されたのディレクトリーの写真ファイル名を
リストアップする。
Private Sub CommandButton3_Click()
    ファイル名取得
End Sub
---------------------------------------------------------------------------------
[開    始]ボタンクリックで指定された写真ファイルを読み込み、指定された
フォルダへ指定された
名前に変更して書き込むをする。
Private Sub CommandButton4_Click()
    写真コピー変更
End Sub

---------------------------------------------------------------------------------
[書き込み先の表示]ボタンクリックで写真読込先のディレクトリーを設定する。
Private Sub CommandButton5_Click()
    ' 書き込み先フォルダ表示
    On Error GoTo ComB5ERR00:         <----  エラー時のジャンプ先を設定
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
    カレントフォルダを書き込み側のパスに移動する。
    If ADir <> "" Then
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) <----  ネットワークドライブの参照
        Else
            ChDrive Left(ADir, 2)          <----  PC内ドライブの参照
            ChDir ADir
        End If
    End If
    'Excel ファイルのみの時を表示したい時は、下記の様に記述します。
    'Application.Dialogs(xlDialogOpen).Show
    '
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(10, 1).Value
    If AAA = "Excel" Or AAA = "" Then _
        Excelブックを表示したいします。
        BBB = Application.GetOpenFilename("Excelブック,*.xlsx"): Exit Sub
    '
    If AAA = Kakuchoshi_B Then _
    指定された拡張子のファイルを表示します。
        BBB = Application.GetOpenFilename(Kakuchoshi): Exit Sub
    '
ComB5ERR00:         <----  エラー処理をする。
    N = Err.Number           <----  エラー番号を取得する。
    「エラー番号 76 : パス名が見つからない」の時、メッセージを表示する。
    If N = 76 Then _
           MsgBox ("フォルダ " & UForm20.TextBox2.Text & "ありません。")
End Sub
---------------------------------------------------------------------------------
[読込み先表示]ボタンクリックで写真読込先のディレクトリーを設定する。
Private Sub CommandButton6_Click()
    ' 読込み先フォルダ表示
    On Error GoTo ComB6ERR00:
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value
    カレントフォルダを書き込み側のパスに移動する。
    If ADir <> "" Then
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) <----  ネットワークドライブの参照
        Else
            ChDrive Left(ADir, 2)          <----  PC内ドライブの参照
            ChDir ADir
        End If
    End If
    'Excel ファイルのみの時を表示したい時は、下記の様に記述します。
    'Application.Dialogs(xlDialogOpen).Show
    '
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(10, 1).Value
    If AAA = "Excel" Or AAA = "" Then _
        Excelブックを表示します。
        BBB = Application.GetOpenFilename("Excelブック,*.xlsx"): Exit Sub
    '
    If AAA = Kakuchoshi_B Then _
    指定された拡張子のファイルを表示します。
        BBB = Application.GetOpenFilename(Kakuchoshi): Exit Sub
    '
ComB6ERR00:
    N = Err.Number 
    If N = 76 Then _
         MsgBox ("フォルダ " & UForm20TextBox2.Text & "ありません。")
End Sub
---------------------------------------------------------------------------------
[文字列置換]ボタンクリックで「文字書換」を実行する。
Private Sub CommandButton7_Click()
    文字書換
End Sub
---------------------------------------------------------------------------------
[オプションボタン1]が選らばれた時設定する。
Private Sub OptionButton1_Click()
    CommandButton3 の表示文字を替える。
    If UForm20.OptionButton1 = True Then _
               UForm20.CommandButton3.Caption = "Excelファイル名抽出"
    Excel/JPG の区分フラグに Excel を書込む。
  Workbooks(AAname).Worksheets(BBname).Cells(10, 1).Value = "Excel"
End Sub
---------------------------------------------------------------------------------
[オプションボタン2]が選らばれた時設定する。
Private Sub OptionButton2_Click()
    CommandButton2 の表示文字を替える。
    If UForm20.OptionButton2 = True Then _
          UForm20.CommandButton3.Caption = Kakuchoshi_B & " 名抽出"
    Excel/任意 の区分フラグに 指定拡張子名 を書込む。
    Workbooks(AAname).Worksheets(BBname).Cells(10, 1).Value = _
                                                                                  Kakuchoshi_B
End Sub
---------------------------------------------------------------------------------
Uform20のフームの初期値を設定する。
Private Sub UserForm_Initialize()
Excel/JPG の区分フラグを読込む。
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(10, 1).Value
    If AAA = "Excel" Or AAA = "" Then
        UForm20.OptionButton1 = True     <----  [オプションボタン1]を
                                                                      選択状態にする。
     [オプションボタン1]を表示「Excelファイル抽出」にする。
        UForm20.CommandButton3.Caption = "Excelファイル抽出"
        Exit Sub
    End If
    If AAA = Kakuchoshi_B Then
        UForm20.OptionButton2 = True     <----  [オプションボタン2]を
                                                                      選択状態にする。
     [オプションボタン2]を表示「(指定拡張子名) 名抽出」にする。
        UForm20.CommandButton3.Caption = Kakuchoshi_B & " 名抽出"
        Exit Sub
    End If
End Sub

-------------------   ここから module1のコード    ----------------------
マクロブック・シートの名前を定義、変数の宣言
        Public N, N1, N2, Nmax, SS, SSS As Single
        Public Const AAname As String = "コピー名前変更マクロ.xlsm"
        Public Const BBname As String = "表紙"
        Public AAA, BBB, CCC As String
        Public Fname1, Fname2, Fname3, Sname, ADir, DirA, DirB As String
        Private Const BIF_RETURNONLYFSDIRS As Long = &H1
        Private Const BIF_EDITBOX As Long = &H10
        Public Kakuchoshi, Kakuchoshi_A As String
        Public Kakuchoshi_B, Kakuchoshi_C As String
        '----------------------------------------------------
        ' ネットワークドライブの参照
        Public Declare Function SetCurrentDirectory _
                Lib "kernel32" Alias "SetCurrentDirectoryA" _
                                 (ByVal lpPathName As String) As Long
        '---------------------------------------------------- 
---------------------------------------------------------------------------------
アドインの表示処理
Sub B01セット()
    Dim Mycontrol As CommandBarControl
    Dim mysubmenu As CommandBarControl
    '
    Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
    Controls.Add(msoControlPopup)
    Mycontrol.Caption = "【■】"
    Mycontrol.OnAction = "Show表示"
End Sub
---------------------------------------------------------------------------------
アドインの削除処理 
Sub B02リセット()
    CommandBars("Worksheet Menu Bar").Controls("【■】").Delete
End Sub
---------------------------------------------------------------------------------
ユーザーフォームの表示処理
Sub Show表示()
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(3, 1).Value
     ' 大文字に変換する
    BBB = AAA: BBB = StrConv(BBB, vbUpperCase) 
     ' 小文字に変換する
    CCC = AAA: CCC = StrConv(CCC, vbLowerCase)  
    ' 例 "JPGファイル(*.jpg),*.jpg"
    Kakuchoshi = AAA & "ファイル(*." & "),*." & CCC 
    Kakuchoshi_A = "*." & CCC     ' 例 "*.jpg"
    Kakuchoshi_B = BBB            ' 例 "JPG"
    Kakuchoshi_C = "." & CCC      ' 例 ".jpg"
    '
    UForm20.Show vbModeless
End Sub

---------------------------------------------------------------------------------
ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
プログラムは、下記のとおりにして下さい。
また、参照設定で Microsoft shell Controls And Automationの設定を忘れないようして下さい。
設定の仕方が、分からない方は、このマクロをダウロードし、不要な箇所を削除して、流用して ください。
[参照設定]のダイヤログの開き方

次の手順で、VBE(Visual Basic Editor)を開きます。

@[ツール] --> [マクロ] --> [マクロの表示] --> 適当なマクロを選び[編集] ----> Visual Basicのダイヤログが開きます。
A[ツール] --> [参照設定] --> 必要とするライブラリィにチェックをいれて [OK]

Sub フォルダ参照(SFolda As Variant)
   
    Dim myShell As Shell32.Shell
    Dim myFolder As Shell32.Folder3
    Dim myItem As Shell32.FolderItem
    Set myShell = New Shell32.Shell
    Set myFolder = myShell.BrowseForFolder( _
        0&, "フォルダを選択してください。" _
        , BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
    If myFolder Is Nothing Then SFolda = "": Exit Sub
        MsgBox myFolder.Self.Path
    '
    SFolda = myFolder.Self.Path
   
    Set myFolder = Nothing
    Set myShell = Nothing
End Sub
----------------------------------------------------------------------------------
コピーする任意の拡張子のファイル名を取得するサブルーチン
Sub ファイル名取得_JPG()
    Dim myPath, myFname, Bname, Sname, AA As Variant
    Dim NN, MM, ZZ As Single
    '
    On Error GoTo ファイル名取得ERR00:   <-- エラー時のジャンプ先を設定
    「マクロの表紙」のリストアップするエリヤを消去する。
       ' セルの内容を消去する
    N = ActiveSheet.Cells(1, 16).Value      <--- 書込みデータの数+1を取得
    If N > 2 Then                  <--- 書込みがある時のみ消去
       C_Range = "O1:Q" & CStr(N)  <--- 消去範囲をレンジデータを作成
       Range(C_Range).Select       <--- 消去範囲を選択する
       Selection.ClearContents  <-- 写真のファイル名を書き込むエリヤを消去
    End If
    ' 写真枚数カウント関数書込み
    ActiveSheet.Cells(1, 16).Select
    ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[10000]C)+1"
    Range("O1").Select
    「マクロの表紙」のリストアップするエリヤにタイトル文字を書き込む。
    Cells(2, 15).Value = "番号"          '
    Cells(2, 16).Value = "変更前名前"
    Cells(2, 17).Value = "変更後名前"
   
    ZZ = 3: MM = 1         <----  初期値を設定する。
                           MM : 番号   ZZ : 書込みセル位置
    '----------------------------------------------------
    カレントフォルダを読込側のパスに移動する。
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value
    If ADir <> "" Then
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) <--- ネットワークドライブの参照
        Else
            ChDrive Left(ADir, 2)          <--- PC内ドライブの参照
            ChDir ADir
        End If
    End If
    読込側のフォルダの写真のファイル一覧を表示する。
    myFname = Application.GetOpenFilename(Kakuchoshi)
          
    If myFname = False Then Exit Sub    <--- ファイルがクリックされ
    '                                                                  ない時、強制終了する。
    '-----------------------------------------------------------------------
    ' 次読込の為のパスを記録する。
        C_cnt = Len(myFname)              <--- 選択した写真のフルパス文字数
        F_array = Split(myFname, "\") <--- Split関数で \ で分割して 配列
                                                                            F_array に代入
        A_cnt = UBound(F_array)     <--- 現在の大きさ(要素数)を調べます
        CCC = F_array(A_cnt)              <--- 最後配列に写真名がある
        L_cnt = Len(CCC) + 1              <--- 写真名の文字数 + \ の分
    ' フォルダのフルパスデータを記録する。
    Workbooks(AAname).Worksheets(CCname).Cells(1, 1).Value = _
                                               Left(myFname, C_cnt - L_cnt)
    '-----------------------------------------------------------------------
    '
    フォルダへのパスデータに \ を付ける。
    myPath = _
         Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value & "\"
    フォルダへのフルパスデータを作成する。
    myFname = Dir(myPath & Kakuchoshi_C)        ' ファイル名取得
    フォルダ内のjpgファイルをすべてリストアップする。
    Do While myFname <> ""
        '
        Cells(ZZ, 15).Value = MM            ' 番号
        Cells(ZZ, 16).Value = myFname       ' ファイル名設定
        '
        ZZ = ZZ + 1: MM = MM + 1
        myFname = Dir()                    ' ファイル名が無くなるまで実行
    Loop
    '
    Exit Sub
ファイル名取得ERR00:         <----  エラー処理をする。
    N = Err.Number           <----  エラー番号を取得する。
    「エラー番号 76 : パス名が見つからない」の時、メッセージを表示する。
    If N = 76 Then MsgBox ("フォルダ " & CCC & "ありませんので、
                             作成して下さい。OKをクリックして下さい。"): Exit Sub
    エラー番号 76 以外の時、メッセージを表示する。
    MsgBox ("設定等に間違いがあります。")
End Sub

------------------------------------------------------------------------
指定された任意の拡張子ファイルを読み込み、指定されたフォルダへ
指定された名前に変更して書き込むサブルーチン

Sub 写真コピー変更_JPG()
    '----------------------------------------------------
    ' このマクロは、Windows Script Host Object Model を使用して
    ' いるので、マクロ-ツール-参照設定で上記のオブジェクトに
    ' チェックを入れて、使用すること。
    '----------------------------------------------------
    On Error GoTo FcopyERR00:     <--- エラー時のジャンプ先を設定
     リストデータの終了セル位置を取得する。
    SS = ActiveSheet.Range("O1000").End(xlUp).Row 
    SSS = 2         <--- リストデータの初期位置
    '
写真コピー10:
    コピーするファイル名を「マクロの表紙」から取得する。
  CCC = _
   Workbooks(AAname).Worksheets(BBname).Cells(SSS, 17).Value
    書込み先のフォルダパスを「マクロの表紙」から取得する。
  ADir = _
   Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
    If ADir = "" Then Exit Sub        <--- 書き込み先の設定が無い時は、
    BBB = ADir                                                           強制終了する
   
    書込み先のフォルダパスを作成する。
    Fname2 = BBB & "\"
    '----------------------------------------------------
    '     同一のファイル名がないかチェック
    '----------------------------------------------------
    Fname2 = ( 書込み先のフォルダのパス )
  CCC = ( コピーするファイル名 )です。
    Fname3 = ( 書込み先のファイルのフルパス )です。
    Fname3 = Fname2 & CCC & Kakuchoshi_C
    
    With New IWshRuntimeLibrary.FileSystemObject
         Fname2=( 書込み先のフォルダのパス )
        BBB=( 読込先のフォルダのパス )です。
        書込み先のフォルダが有るかチェックする。
        If Not .FolderExists(Fname2) Then
            書き込み先フォルダがない時メッセージを表示する。
          MsgBox "コピー先のフォルダ" & BBB & "が見つかりません。", _
                                                                        vbExclamation
        GoTo 写真コピー10B:
        End If
        書き込み先に同一のファイル名がないかチェックする。
        If Not .FileExists(Fname3) Then
            a = a   <--- デバック時のブレークポイントを設定する位置。
        Else
            書き込み先に同一のファイル名がある時メッセージを表示する。
            MsgBox "同一ファィル「 " & CCC & " 」があります。", _
                                                                    vbExclamation
            GoTo 写真コピー10B:
        End If
        '
    End With

    '----------------------------------------------------
    ' 読込側のパス設定 写真名
    '----------------------------------------------------
    読込むファイル名を「マクロの表紙」から取得する。
  Sname = _
    Workbooks(AAname).Worksheets(BBname).Cells(SSS, 16).Value
    読込むファイルのフルパスを作成する。
  Fname1 = _
    Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value _
    & "\" & Sname
    '
    '----------------------------------------------------
    '      指定フォルダへ、書き込む
    '----------------------------------------------------
 Fname1のフルパスのファイルをFname2で示すフォルダにコピーする。
    With New IWshRuntimeLibrary.FileSystemObject
      
        .CopyFile Fname1, Fname2, True
      
    End With
    '
    '----------------------------------------------------
    '       名前変更
    '----------------------------------------------------
    ' 書込み側のパス設定
    カレントフォルダを書込み側のパスに移動する。
    ADir = _
    Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
    If ADir <> "" Then
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) <----  ネットワーク
        Else                                                     ドライブの参照
            ChDrive Left(ADir, 2)          <--- PC内ドライブの参照
            ChDir ADir
        End If
    End If
  Sname=( 変更前のファイル名 )  CCC=( 変更後のファイル名 )です。
    DirA = Sname: DirB = CCC & Kakuchoshi_C
    
    Name DirA As DirB    <--- ファイル名を DirA から DirB へ変更
    すべて終了したか判定する。
    If SSS < SS Then SSS = SSS + 1: GoTo 写真コピー10:
    '
    MsgBox ("写真コピー名前変更完了")    <---  完了メッセージ。
    'Unload UForm20    <--- を取れば完了と同時に表示フォームが
    '                                              消去します。
写真コピー10B:
        Exit Sub
        
FcopyERR00:                  <----  エラー処理をする
    N = Err.Number           <----  エラー番号を取得する
「エラー番号 76 : パス名が見つからない」の時、メッセージを表示する
    If N = 76 Then MsgBox ("フォルダ " & CCC & "ありません。")
「エラー番号 75 : パス名無効です」の時、メッセージを表示する
    If N = 75 Then MsgBox ("フォルダ " & CCC & "作成済です。")

End Sub
-----------------------------------------------------------------------
Sub ファイル名取得_JPG()と内容は、同じなので説明は省略します。
Sub ファイル名取得_Excel()
    '
    On Error GoTo ファイル名取得_ExcelERR00:
    
    Bname = ActiveWorkbook.Name          ' ブック名取得
    Sname = ActiveSheet.Name             ' シート名取得
    '
    N = _
    Workbooks(AAname).Worksheets(BBname).Cells(1, 16).Value
    If N > 2 Then
        E_Range = "O1:Q" & CStr(N)
        Range(E_Range).Select
        Selection.ClearContents              ' 消去
    End If
    Cells(2, 15).Value = "番号"
    Cells(2, 16).Value = "変更前名前"
    Cells(2, 17).Value = "変更後名前"
    ActiveSheet.Cells(1, 16).Select
    ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[10000]C)+1"
   
    ZZ = 3: MM = 1
    '----------------------------------------------------
    ' カレントパス変更
    ADir = _
     Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value
    If ADir <> "" Then
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) ' ネットワークドライブの参照
        Else
            ChDrive Left(ADir, 2)   ' PC内ドライブの参照
            ChDir ADir
        End If
    End If
    '
    myFname = _
      Application.GetOpenFilename("写真ファイル(*.xlsx),*.xlsx")
    '
    If myFname = False Then Exit Sub      ' 強制終了
    '----------------------------------------------------
    Filename$ = Dir(myFname, vbNormal)
    Sname = Filename$                     ' ファイル名
    '-----------------------------------------------------------------------
    ' 次読込の為のパスを記録する。
        ' 選択した写真のフルパス文字数
        C_cnt = Len(myFname)              
        ' \ で分割して 配列 F_array に代入
        F_array = Split(myFname, "\")         
        ' 現在の大きさ(要素数)を調べます
        A_cnt = UBound(F_array)           
        ' 最後配列に写真名がある
        CCC = F_array(A_cnt)              
        ' 写真名の文字数 + \ の分
        L_cnt = Len(CCC) + 1              

    ' 読込側のパス設定( \写真名 分を取る処理 )
    Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value = _
                                                Left(myFname, C_cnt - L_cnt)
    '-----------------------------------------------------------------------
    ' ドライブ名・フォルダ名取得
    myPath = _
    Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value & "\"
    
    myFname = Dir(myPath & "*.xlsx")        ' ファイル名取得
    '
    Do While myFname <> ""
        '
        Cells(ZZ, 15).Value = MM            ' 番号
        Cells(ZZ, 16).Value = myFname       ' ファイル名設定
        '
        ZZ = ZZ + 1: MM = MM + 1
        myFname = Dir()                    ' ファイル名が無くなるまで実行
    Loop
    '
    Exit Sub
ファイル名取得_ExcelERR00:
    N = Err.Number
    If N = 76 Then MsgBox ("フォルダ " & CCC & "ありませんので、
                       作成して下さい。OKをクリックして下さい。"): Exit Sub
    MsgBox ("設定等に間違いがあります。")
End Sub

------------------------------------------------------------------------
Sub 写真コピー変更_JPG()と内容は、同じなので説明は省略します。
Sub コピー変更_Excel()
    '----------------------------------------------------
    ' このマクロは、Windows Script Host Object Model を使用して
    ' いるので、マクロ-ツール-参照設定で上記のオブジェクトに
    ' チェックを入れて、使用すること。
    '----------------------------------------------------
    On Error GoTo コピー変更_ExcelERR00:
    '
    With ActiveWindow.RangeSelection
        SSS = .Rows.Row               ' 縦位置 start
        SS = .Rows(.Rows.Count).Row   ' 縦位置 end
    End With
    '
コピー変更_Excel10:
    '
    CCC = _
     Workbooks(AAname).Worksheets(BBname).Cells(SSS, 17).Value
    ' 書込み先のフォルダパス
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
    If ADir = "" Then Exit Sub
    BBB = ADir
   
    ' 貼付け先サブフォルダのパス
    Fname2 = BBB & "\"
    '----------------------------------------------------
    '     同一のファイル名がないかチェック
    '----------------------------------------------------
    
    Fname3 = Fname2 & CCC & ".xlsx"
    
    With New IWshRuntimeLibrary.FileSystemObject
        '
        If Not .FolderExists(Fname2) Then
            MsgBox "コピー先のフォルダ" & BBB & "が見つかりません。", _
                                                                               vbExclamation
        GoTo コピー変更_Excel10B:
        End If
        '
        If Not .FileExists(Fname3) Then
            a = a
        Else
            MsgBox "同一ファィル「 " & CCC & " 」があります。", _
                                                                        vbExclamation
            GoTo コピー変更_Excel10B:
        End If
        '
    End With

    '----------------------------------------------------
    ' 読込側のパス設定 写真名
    '----------------------------------------------------
    '
    Sname = _
    Workbooks(AAname).Worksheets(BBname).Cells(SSS, 16).Value
    Fname1 = _
    Workbooks(AAname).Worksheets(BBname).Cells(1, 1).Value _
    & "\" & Sname
    '
    '----------------------------------------------------
    '      指定フォルダへ、書き込む
    '----------------------------------------------------
    With New IWshRuntimeLibrary.FileSystemObject
      
        .CopyFile Fname1, Fname2, True
      
    End With
    '
    '----------------------------------------------------
    '       名前変更
    '----------------------------------------------------
    ' 書込み側のカレントパス変更
    '
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value
    If ADir <> "" Then
        ' H25.06.09  追加
        If Left(ADir, 2) = "\\" Then
            Call SetCurrentDirectory(ADir) ' ネットワークドライブの参照
        Else
            ChDrive Left(ADir, 2)          ' PC内ドライブの参照
            ChDir ADir
        End If
    End If
    
    DirA = Sname: DirB = CCC & ".xlsx"
    
    Name DirA As DirB
    '
    If SSS < SS Then SSS = SSS + 1: GoTo コピー変更_Excel10:
    '
    MsgBox ("写真コピー名前変更完了")
    'Unload UForm20
    '
コピー変更_Excel10B:
        Exit Sub
        
コピー変更_ExcelERR00:
    N = Err.Number
    If N = 76 Then MsgBox ("フォルダ " & CCC & "ありません。")
    If N = 75 Then MsgBox ("フォルダ " & CCC & "作成済です。")

End Sub
------------------------------------------------------------------------
ドラックしたセル内の文字列から、マクロ表紙のセル(2,9)(2,10)で
指定された文字に置換する。
Sub 文字書換()
    ' 任意文字削除
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(2, 9).Value
    BBB = Workbooks(AAname).Worksheets(BBname).Cells(2, 10).Value
AAA・BBBの両方にデータが無いときは、強制終了させる。
    If AAA = "" Or BBB = "" Then Exit Sub
変数AAAで指定された文字を変数BBBで指定された文字に置換する。
    Selection.Replace What:=AAA, Replacement:=BBB, LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False
End Sub
------------------------------------------------------------------------

TOPへ戻る