VBAでExcelのセルの一覧からファイル名の変更が

前へ 次へ
このQ&Aのポイント
  • 会社で大量のファイル名を変更していますが、Excelで一覧から変更できれば能率的なので作っていますが、困っています。
  • VBAを使用してExcelのセルの一覧からファイル名を変更する方法について教えてください。
  • リネームサブルーチンを使用してExcelの一覧からファイル名を変更しようとしていますが、うまく動作しません。エラーも発生しません。どうすれば問題を解決できるでしょうか。
回答を見る
  • ベストアンサー

VBAでExcelのセルの一覧からファイル名の変更が

こんにちは。会社で大量のファイル名を変更していますが、Excelで一覧からを変更できれば能率的なので作っていますが、困っています。下記のものです。 Sub リネーム() Dim i As Long　 Dim NEWファイル As String　 Dim OLDファイル As String　 Dim パス As String For i = 1 To Range("B65536").End(xlUp).Row パス = Cells(2, 1).Value OLDファイル = パス & Cells(i, 2).Value NEWファイル = パス & Cells(i, 3).Value If Dir(OLDファイル) <> "" Then Name OLDファイル As NEWファイル End If Next i End Sub ※A2にはC:\Documents and Settings\M．Co，\デスクトップ\リネームと入っています。B1には変更前の001.jpg、C1には変更するa-1.jpgとファイル名が入っています。実行してもファイル名は変更されません。エラーもでません。よろしくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

OLDファイル = パス & "\" & Cells(i, 2).Value NEWファイル = パス & "\" & Cells(i, 3).Value ではないでしょうか？

cocoku
質問者

お礼

さっそくの回答ありがとうございます。 単純ミスですみません。全く気づきませんでした。 解決しました。（*^_^*）

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. その他（プログラミング・開発）

関連するQ&A

  • ExcelのVBAについて

    こんにちは、VBA初心者です。 C:\pictureの中に以下のファイルがあります。 DSC_0134.JPG～DSC_0154.JPG これらのファイルをExcelのA列1～20行に書かれた文字△○％＆◎～▲▽％％★に.JPGをつけて保存したくて以下のコードを書きました。 Dim buf As String Dim msg As String Dim i As Integer Dim A As Variant i = 1 buf = Dir("dsc*.jpg", vbNormal) Do While buf <> "" Do While i < 21 buf = Dir() msg = buf 'msg=元の名前 A = Worksheets("sheet1").Cells(i, 1).Value 　　　　Worksheets("sheet1").Cells(i, 2).Value = msg 　　　　 　　　　Name "C:\picture\msg" As "C:\picture\A.jpg" 　　　　i = i + 1 Loop Loop Name "C:\picture\msg" As "C:\picture\A.jpg"のところで、「ファイルがありません。」となってしまいます。 あと、Worksheets("sheet1").Cells(i, 2).Value = msgのところで、\pictureの中の最初のファイル（DSC_0134.JPG）を表示しません。 どこを直せばよいのでしょうか？

  • 【VBA】ExcelマクロでCSVファイルに保存したデータが""で囲まれてしまう

    添付図のような、Excel2003で作成した表内のデータを CSVで保存するマクロを作成したのですが、 図のように、CSVファイルに「""」で値が囲まれた状態で、 保存されてしまいます。 下記にマクロを記載しますので、 どうすれば文字列が「""」で囲まれずに、 カンマ区切りだけのデータで出力されるのか、 ご存知の方おられましたら、ご教示お願い致します。 Sub csv保存() Dim フォルダ名 As String Dim パス名 As String Dim ファイル名 As String Dim データ As Variant Dim 行数 As Long, 列数 As Integer Dim i As Integer, j As Long, k As Long ファイル名 = "test.csv" フォルダ名 = "csv" パス名 = ActiveWorkbook.Path & "\" & _ フォルダ名 'csvフォルダが存在しなければ作成する If Dir(パス名, vbDirectory) = "" Then MkDir パス名 End If ChDir パス名 Open ファイル名 For Output As #1 For i = 1 To Worksheets.Count Worksheets(i).Activate Worksheets(i).Cells(1, 1).Select ActiveCell.CurrentRegion.Select 行数 = Selection.Rows.Count 列数 = Selection.Columns.Count For j = 1 To 行数 For k = 1 To 列数 - 1 データ = Selection.Cells(j, k) _ .Value Write #1, データ; Next k Write #1, Selection.Cells(j, 列数) _ .Value Next j Next i Close #1 End Sub

  • excelのファイルとセル値を書き出したい

    excel2003を利用しています。 とあるフォルダにある excelファイル名(自分自身のファイルを除く） を全て書き出して、 且つ A１セルの値をB列に書き出すことを、やろうとvbaを作ってみましたが。 最後のファイルのA1セルを書きだすところで、エラーになっていまい そこだけ空白になってしまいます。※写真参照 記述は以下の通りです。どのように修正すればよいか 教えていただけないでしょうか？ また他にもっと優れた記述があれば、そちらも教えて欲しいです。 よろしくお願いします。 Sub test() Dim buf As String, cnt As Long Dim Path As String Path = ThisWorkbook.Path & "\" buf = Dir(Path & "*.xls") cnt = 2 Do While buf <> "" If buf <> ThisWorkbook.Name Then cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Workbooks.Open Filename:=Path & "\" & buf MsgBox Workbooks(buf).Worksheets(1).Range("A1").Value Cells(cnt, 2) = Workbooks(buf).Worksheets(1).Range("A1").Value Workbooks(buf).Close End If Loop End Sub

  • (VBA) ファイル名の変更　- 拡張子を参考 -

    ファイル名の変更をEXCEｌ（VBA)で行いたいと思います。 以下を参考にしました https://akira55.com/file_change_name/ 旧ファイル名を新ファイル名に変更する場合、 　拡張子は旧ファイルと同じなので 　新ファイルには拡張子が無い形式で記載されています。 一応、上手く処理出来ているようでエラー無く完了しますが、 　問題があります。 拡張子を取り出すのに"."から右側を取り出していますが "."が複数ある場合は処理できません。 　"."が複数ある場合、最後の"."から右側を取り出すようにようにするには 　どのようにコードを変更しますか　？ Sub FilenameChange01() '指定したファイル名を変更します。 Dim ws01 As Worksheet Dim lRow, I As Single Dim FolderName, OldFile, NewFile As String Dim OldFile_Kakucyoushi, NewFile_Kakuchoushi As String Set ws01 = Worksheets("ReName") FolderName = ws01.Range("C1") '保存されている保存先（フォルダー） lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得 For I = 4 To lRow '最終行まで繰り返す OldFile = FolderName & "\" & ws01.Cells(I, "B") NewFile = FolderName & "\" & ws01.Cells(I, "C") OldFile_Kakucyoshi = Right(ws01.Cells(I, "B"), Len(ws01.Cells(I, "B")) - (Application.WorksheetFunction.Find(".", ws01.Cells(I, "B")) - 1)) NewFile_Kakucyoshi = OldFile_Kakucyoshi NewFile = NewFile & NewFile_Kakucyoshi Name OldFile As NewFile 'ファイル名を変更します。 Next I End Sub

  • EXCELのVBAでのCSVファイル読込みと検索

    エクセルのマクロでCSVファイルを読み込み、その行の得意先サブコードをキー項目として別のCSVファイルを検索し電話番号とFAX番号を取得するという作業を下記のようなコードで作成しました。 Dim Obj As Object Dim Path As String Dim FName As String Dim i As Long Dim buf As String Dim tmp As Variant Dim WSH As Variant Dim CN As ADODB.Connection Dim RS As ADODB.Recordset '自分のPCのデスクトップをPathとして設定します。 Set WSH = CreateObject("Wscript.Shell") Path = WSH.SpecialFolders("Desktop") & "\" '得意先マスタ.csvをOPENする際の準備処理 '3行目のPropertiesがCSVファイルの定義(excelをOPENする時とは異なります) Set CN = New ADODB.Connection CN.Provider = "Microsoft.Jet.OLEDB.4.0" CN.Properties("Extended Properties") = "Text;HDR=YES;FMT=Delimited" CN.Open Path '得意先サブマスタ.CSVを開きます。 Open Path & "得意先サブマスタ.csv" For Input As #1 i = 1 Do Until EOF(1) Line Input #1, buf tmp = Split(buf, ",") If i = 1 Then Else Cells(j, 1).Value = Left(tmp(3), 4) '会社コード Cells(j, 2).Value = Right(tmp(3), 4) '店舗コード Cells(j, 3).Value = tmp(3) '会社＠店舗 Cells(j, 4).Value = tmp(4) '得意先コード Cells(j, 5).Value = tmp(5) '店舗名 Set RS = New ADODB.Recordset RS.Open "SELECT * FROM 得意先マスタ.csv WHERE 得意先コード = " & tmp(4) & " ", CN If RS.EOF Then Cells(j, 6).Value = "???" Cells(j, 7).Value = "???" Else Cells(j, 6) = RS.Fields("電話番号") Cells(j, 7) = RS.Fields("FAX番号") End If End If i = i + 1 Loop このコードで動作確認すると途中で動作が止まってしまい応答なし状態になってしまいます。どこで止まるかは一定ではありません。CSVファイルの内容も確認したのですが、特におかしいような箇所はありませんでした。 OSはWINDOWS７、EXCELは2016です。 コード自体に修正した方がいいような箇所があればアドバイスいただきたいと思っております。宜しくお願い致します。

  • エクセルのマクロで複数セル指定は？

    以前（7月22日　質問No.936181）の質問でご回答を頂いたマクロなんですが、 Private Sub Worksheet_Change(ByVal Target As Range) Dim MyData As String Dim i As Integer Dim ImaNanji As String Dim SakkiNanji As String Dim ImaNanpun As String Dim SakkiNanpun As String SakkiNanpun = Cells(2, 3).Value ImaNanji = Cells(1, 3).Value ImaNanpun = Mid(ImaNanji, Len(ImaNanji) - 4, 2) If ImaNanpun <> SakkiNanpun Then Application.EnableEvents = False For i = 10 To 2 Step -1 MyData = Cells(i - 1, 2).Value Cells(i, 2).Value = MyData Next i MyData = Cells(1, 1).Value Cells(1, 2).Value = MyData Cells(2, 3).Value = ImaNanpun Application.EnableEvents = True End If End Sub A1のデータをB1からB10に一分おきにつぎつぎに書き込むというものなんですが、ひとつのセルではなく複数のセル（例えばA1からA30の30個のセル）をいっぺんに書き込むようにしたいのですが可能でしょうか？ よろしくお願いします。

  • ファイル名を合成すると検索できないのでしょうか？

    下記のような式がありまして、一度作成したファイルは上書きされないはずですが何回やっても上書きされてしまいます。 これはファイルを検索していないのでしょうか？ 既にファイルがあったら終了するはずですが何か間違えていますか？ 'ファイル作成 Sub MakeCopyFile(newfile As String, orgfile As String) If SearchFile(newfile) Then Exit Sub End If Set fs = CreateObject("Scripting.FileSystemObject") fs.CopyFile orgfile, newfile End Sub ' ファイル検索 Function SearchFile(fname As String) As Boolean SearchFile = False Set fs = Application.FileSearch With fs .Filename = fname If .Execute() > 0 Then SearchFile = True End If End With End Function Sub Macro1() Dim name As String '名前 Dim fname As String 'ファイル名 Dim directory As String '作成先ディレクトリ Dim fullpath As String 'フルパス Dim orgfile As String '雛形のファイル名 Dim editbook As Workbook '個人データブック Dim id As String '番号 directory = "H:\test\" orgfile = "H:\test\雛形.xls" For i = 1 To 100 name = ThisWorkbook.Worksheets("Sheet2").Cells(i, 10).Value id = ThisWorkbook.Worksheets("Sheet2").Cells(i, 12).Value If name = "" Then Exit For End If 'コピーしたファイルを作成する fname = name + id + ".xls" 'ファイル名合成 fullpath = directory + fname 'フルパス合成 Call MakeCopyFile(fullpath, orgfile) 'ファイル作成 Workbooks.Open Filename:=fullpath Set editbook = Workbooks(fname) editbook.Worksheets("Sheet3").Cells(8, 14).Value = name editbook.Worksheets("Sheet3").Cells(8, 10).Value = id '※(その他必要な処理があれば追加してください) editbook.Close (True) Next i End Sub

  • EXCEL、VBAについて

    ' GLOBAL変数の定義 Dim CurrentDir As String '現在のディレクトリ Dim ThisBook As String '現在のブック名 Dim WorkSheetName1 As String Dim WorkSheetName2 As String Dim ConfigSheetName As String Dim ListSheetName1 As String Dim ListSheetName2 As String Dim ListSheetName3 As String Dim ListSheetName4 As String Dim ListSheetName5 As String Dim ListSheetName6 As String Dim ListSheetName7 As String Dim ErrorFlag As Integer 'エラーフラグ　0:正常 1:エラー Sub 初期設定() CurrentDir = ActiveWorkbook.Path '現在のディレクトリ ThisBook = ActiveWorkbook.Name '現在のブック名 WorkSheetName1 = "work1" WorkSheetName2 = "work2" ConfigSheetName = "設定" ListSheetName1 = "****" ListSheetName2 = "****" ListSheetName3 = "****" ListSheetName4 = "****" ListSheetName5 = "****" ListSheetName6 = "****" ListSheetName7 = "****" Application.DisplayAlerts = False 'EXCELの警告を無視する End Sub Sub CSV取り込み() Dim LoadBook As String '読み込みブック名 Dim DataMaxCol As Integer '読み込みデータ有効最大カラム数 Dim WorkStartRow As Integer 'workシート開始行 Dim WorkEndRow As Integer 'workシート終了行 Dim ListMaxCol As Integer '一覧シート有効最大カラム数 Dim ListStartRow As Integer '一覧シート開始行 '初期設定コール Call 初期設定 'workシートをクリア DataMaxCol = Sheets(ConfigSheetName).Range("F2").Value WorkStartRow = Sheets(ConfigSheetName).Range("F3").Value WorkEndRow = Sheets(ConfigSheetName).Range("F4").Value Sheets(WorkSheetName1).Select Range(Cells(WorkStartRow, 1), Cells(WorkEndRow, DataMaxCol)).ClearContents '受注データファイルを選択しオープン SelectedPath = Application.GetOpenFilename("CSVファイル (*.csv), *.csv") If SelectedPath <> "False" Then Workbooks.Open Filename:=(SelectedPath) Else 'キャンセル時は終了 Exit Sub End If LoadBook = ActiveWorkbook.Name '現在のブック名 '受注データの開始行をチェック I = WorkStartRow '受注データの最終行をチェック Do Until ActiveCell.Value = "" I = I + 1 Cells(I, 1).Select Loop WorkEndRow = I - 1 '受注データをコピー Range(Cells(WorkStartRow, 1), Cells(WorkEndRow, DataMaxCol)).Select Selection.Copy 'workシートへペースト Windows(ThisBook).Activate Sheets(WorkSheetName1).Select Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False '受注データファイルをクローズ Windows(LoadBook).Close End Sub このマクロを実行するとインデックスが有効範囲にありませんとなりエラーとなってしまいます。 あと最後のデータファイルをクローズできればOKなのですが・・。 どこがいけないんでしょうか？

  • Excel VBAの繰返し処理を教えて下さい

    マクロを始めたばかりの初心者です。 どなたかご教示下さい。 リストから担当者社員番号をキーとして既定のシートにデータ転記し、別ファイルコピー後名前を付けて保存するというマクロを作成しています。 ご教示頂きたいのは、担当者別にファイルを作成したいのですが、 １行ごとの処理になり、無限ループでVBAが終了しません。 色々調べてみたものの、解決策が見つかりません。 どなたかご教示いただけないでしょうか。 読みにくいコードですが何卒よろしくお願い致します。 サンプルコード Sub 担当者用_個人用() Dim 行 As Integer Dim 年月 As String Dim メール行 As Integer Dim 担当者用 As String Dim 社員番号 As String Dim 社員名 As String Dim 残業対象 As String Dim 所属コード As String Dim 所属名 As String Dim 事業所コード As String Dim 事業所名 As String Dim 社員区分 As String Dim 平日時間外_m As String Dim 休日時間外_m As String Dim 時間外合計 As String Dim 前月時間外合計 As String Dim 前々月時間外合計 As String Dim 平均 As String Dim 問診票 As String Dim 削減書 As String Dim 担当者社員番号 As String Dim 担当者 As String Application.ScreenUpdating = False Sheets("個人用").Select 年月 = InputBox("ＯＴレポートの「年月」を入力してください　 　　例：（前月）2012年9月 →　201209") Range("A2") = 年月 Sheets("健康診断問診票").Select 行 = 5 メール行 = 5 　【こちらの繰返し処理が無限ループになっています。ご教示頂けないでしょうか】 　　　　　 Do Until Cells(行, 17).Value = "" If Cells(行, 17).Value <> 担当者社員番号 Then End If 出力処理: 社員番号 = Cells(行, 1).Value 社員名 = Cells(行, 2).Value 残業対象 = Cells(行, 3).Value 所属名コード = Cells(行, 4).Value 所属名 = Cells(行, 5).Value 事業所コード = Cells(行, 6).Value 事業所名 = Cells(行, 7).Value 社員区分 = Cells(行, 8).Value 平日時間外_m = Cells(行, 9).Value 休日時間外_m = Cells(行, 10).Value 時間外合計 = Cells(行, 11).Value 前月時間外合計 = Cells(行, 12).Value 前々月時間外合計 = Cells(行, 13).Value 平均 = Cells(行, 14).Value 問診票 = Cells(行, 15).Value 削減書 = Cells(行, 16).Value 担当者社員番号 = Cells(行, 17).Value 担当者 = Cells(行, 18).Value Sheets("個人用").Select Range("A5").Select Cells(メール行, 1).Value = 社員番号 Cells(メール行, 2).Value = 社員名 Cells(メール行, 3).Value = 残業対象 Cells(メール行, 4).Value = 所属名コード Cells(メール行, 5).Value = 所属名 Cells(メール行, 6).Value = 事業所コード Cells(メール行, 7).Value = 事業所名 Cells(メール行, 8).Value = 社員区分 Cells(メール行, 9).Value = 平日時間外_m Cells(メール行, 10).Value = 休日時間外_m Cells(メール行, 11).Value = 時間外合計 Cells(メール行, 12).Value = 前月時間外合計 Cells(メール行, 13).Value = 前々月時間外合計 Cells(メール行, 14).Value = 平均 Cells(メール行, 15).Value = 問診票 Cells(メール行, 16).Value = 削減書 Cells(メール行, 17).Value = 担当者社員番号 Cells(メール行, 18).Value = 担当者 '個別ファイル作成 Sheets("個人用").Select Sheets("個人用").Copy 年月 = Cells(2, "A") 担当者社員番号 = Cells(5, "Q") 担当者 = Cells(5, "R") Application.DisplayAlerts = False 'メッセージを出さない ActiveWorkbook.SaveAs Filename:="C:\担当者用\" & ("勤怠抽出" & 年月 & "(" & 担当者社員番号 & " " & 担当者 & "さん" & ")") & ".xls" ActiveWorkbook.Save ActiveWindow.Close Sheets("個人用").Select Rows("5:5").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Sheets("健康診断問診票").Select 行の終わり: 行 = 行 + 1 Loop Sheets("ファイル作成").Select Range("A30").Select ActiveWorkbook.Save Application.ScreenUpdating = True MsgBox "ファイル作成が終了しました" End Sub

  • マクロでセルに入れたファイル名の画像を隣のセルに読

    みこむ。 マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業をVBA でつくりました。 そのファイル名がないときは、飛ばすようにできないでしょうか。 「 Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG")」 ここでとめられてしまいます。 　　　A(No）　　B(名)　　　　C(画像) --------------------------------------------- 1　　　1　　　test01　　　D:\画像\teet01.JPG 2　　　2　　　test02　　　D:\画像\teet02.JPG 3　　　3　　　test03　　　D:\画像\teet03.JPG Private Sub CommandButton1_Click() Dim i As Long Dim myPic As Object Dim myCell As Range Dim sCurDir As String sCurDir = ThisWorkbook.Path & "\画像\" For i = 6 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row Step 6 Set myCell = Range("B" & i) Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG") With myPic .Left = Range("C" & i).Left .Top = Range("C" & i).Top .Width = Range("C" & i).MergeArea.Width .Height = Range("C" & i).MergeArea.Height End With Set myPic = Nothing Next i End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する