Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


44607 / 76732 ←次へ | 前へ→

【37140】Re:ファイルを開いて、あるシートをアクティブにする
回答  Kein  - 06/4/23(日) 13:17 -

引用なし
パスワード
   >あるセルの値と同じ名前の図面ファイルがCドライブ、又は
>ネットワーク経由のフォルダにあります。
>その値と同じファイル名のファイルを検索して
>コピーして、名前を変えて新しいフォルダにはりつけます。
>”そしてその結果を、テキストファイルに
>「元のファイル名→新しいファイル名」
>といった感じで、貼り付けたフォルダに残したいのです”

1 検索するファイル名は、マクロ実行ブックのSheet1のA2以下に入力されている。
2 ネットワーク上のフォルダーのパスは、定数 CpFol で宣言。
3 コピー先フォルダーは、通常ブックを保存しているフォルダー
4 コピー後のファイル名は、元のファイル名の先頭に番号を付ける。
5 コピーしたファイルのリストを書いたテキストは、CpyLog.txt とする。

Sub MyFile_Copy()
  Dim i As Long
  Dim MyR As Range, C As Range
  Dim PsFol As String, MyF As String
  Dim Mylog As String, NewF As String
  Const CpFol As String = _
  "\\Computername\c\My Documents\"
  '↑実際の保存先フォルダーのパスに変更する

  PsFol = Application.DefaultFilePath & "\"
  Mylog = PsFol & "CpyLog_" & Format(Date, "yymmdd") & ".txt"
  With Worksheets("Sheet1")
   If .Range("A65536").End(xlUp).Row = 1 Then
     MsgBox "ブック名の入力がありません", 48: Exit Sub
   End If
   Set MyR = .Range("A2", .Range("A65536").End(xlUp))
  End With
  If Dir(Mylog) <> "" Then Kill Mylog
  Open Mylog For Output Access Write As #1
  For Each C In MyR
   If LCase(Right$(C.Value, 4)) <> ".xls" Then GoTo NLine
   MyF = "C:\" & C.Value
   If Dir(MyF) = "" Then
     MyF = CpFol & C.Value
     If Dir(MyF) = "" Then
      Print #1, C.Value & " : NotFound"
      GoTo NLine
     End If
   End If
   i = i + 1
   NewF = Left$(C.Value, Len(C.Value) - 4) & "_" & i & ".xls"
   FileCopy MyF, PsFol & NewF
   Print #1, C.Value & " : " & NewF
NLine:
  Next
  Close #1: Set MyR = Nothing
  MsgBox "ファイルコピーとログの作成を終了", 64
End Sub

0 hits

【37131】ファイルを開いて、あるシートをアクティブにする maki 06/4/22(土) 23:47 質問
【37132】Re:ファイルを開いて、あるシートをアクテ... かみちゃん 06/4/22(土) 23:59 発言
【37133】Re:ファイルを開いて、あるシートをアクテ... maki 06/4/23(日) 1:27 発言
【37134】Re:ファイルを開いて、あるシートをアクテ... かみちゃん 06/4/23(日) 1:39 発言
【37136】Re:ファイルを開いて、あるシートをアクテ... maki 06/4/23(日) 2:36 発言
【37140】Re:ファイルを開いて、あるシートをアクテ... Kein 06/4/23(日) 13:17 回答

44607 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free