ファイル名変更してコピー

質問

エクセル２０００で次のような処理が出来ますでしょうか。
まず前提として、シート1のＡ列にフォルダＡの中の001.jpg～100.jpgと言う画像
がリンク付けてあります。（Ａ1は001.jpgに～Ａ100は100.jpgに）。
そこで、シート1のＢ列にB1からB***まで数字をガンガン打ち込んでいきます。
打ち込み終わりで、実行すると例えばＢ１が30だとすると030.jpgを
1-030-001.jpg（　（１から連番）－（画像番号）－（検索された回数）.jpg　）
と言うふうにしてフォルダＢにコピーしたいのですが・・。
こんな事出来ますでしょうか？

回答No.1

nishi6 · ベストアンサー

こんな感じでしょうか。質問の通りにファイルをコピーするはずです。(Excel2000)

コピー先ファイル名の『1から連番』は1～数桁になり、ソートなどには不向きかもしれません。
　DesFile = DesFolder & "\" & (rwCot + 1) &・・・・を（質問のまま）
　DesFile = DesFolder & "\" & RIGHT("0000" & (rwCot + 1), 4) &・・・にすれば連番が４桁固定になります。

フォルダＡ、Ｂは指定してください。

シートのコードウインドウに貼り付けます。
↓
Dim schNum() As Integer '検索された回数

Sub HyperFileCopy()
　　Const SrcFolder = "A:\FolderA" 'コピー元のフォルダ *** 指定する ***
　　Const DesFolder = "A:\FolderB" 'コピー先のフォルダ *** 指定する ***

　　Const jpgNum = 100 'jpgファイルの個数
　　ReDim schNum(jpgNum) As Integer '検索された回数
　　Dim rwCot As Integer 'カウンタ(連番)

　　Dim inpNo As Integer '入力した数値
　　Dim SrcFile As String 'コピー元のファイル名
　　Dim DesFile As String 'コピー先のファイル名

　　While Range("B1").Offset(rwCot, 0) <> "" 'B列を空白セルになるまで読み込む
　　　　inpNo = Range("B1").Offset(rwCot, 0).Value

　　　　'コピー元のファイル名
　　　　SrcFile = SrcFolder & "\" & Range("A" & inpNo).Value
　　　　'コピー先のファイル名
　　　　schNum(inpNo) = schNum(inpNo) + 1 '検索された回数を増やす
　　　　DesFile = DesFolder & "\" & (rwCot + 1) & "-" & _
　　　　　　　　　Right("000" & inpNo, 3) & "-" & _
　　　　　　　　　Right("000" & schNum(inpNo), 3) & ".jpg"

　　　　'ファイルをコピー
　　　　FileCopy SrcFile, DesFile

　　　　rwCot = rwCot + 1 '次の行
　　Wend
End Sub

お礼

重ね重ね本当にありがとうございました。
お礼の言葉もございません。
おかげさまでうまく行きました。自分でやってたら
何年かかるか・・と思うと恐いくらいです。

補足

nishi6さん、本当にありがとうございます。感謝というか感動です。
おかげさまで出来ました。
一つ質問漏れがありまして、変更したファイル名が　****－***－001.jpg
となった場合（つまり一回目に検索されたファイル）はコピーせず、
そのまま次の処理を続けることは出来ますか？
ファイルをコピーする前に何か一文たせばいいんでしょうか・・？

回答No.2

nishi6

＞・・・（つまり一回目に検索されたファイル）はコピーせず・・・
については、

　　If schNum(inpNo) <> 1 Then
　　　　'１回目でなければファイルをコピー
　　　　FileCopy SrcFile, DesFile
　　End If

とすれば大丈夫でしょう。

お礼

下のほうに書いてしまいましたが、
本当にありがとうございました。