みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

VBSでファイルをコピーして名前変更

VBSで現在下記のようなコードを組んでいます。
動作としてはコードが組んであるVBSファイルにエクセルシートをドラック&ドロップすると、ブックのパスが外れてファイル名の先頭に
シート内のセルE5の文字がつくようになっています。

そしてそのファイル名に指定した文字がある場合
指定したフォルダへ移動されます。
今回行いたいのは、その移動したあとの処理で
移動したファイルをそのフォルダ内でコピーして
名前を変更したいです。

例えば移動してきたファイル名が
#101-1test.xlsxだとして、そのファイルをコピーして
ABC101-1_DEFG.xlsxという名前で同じフォルダ内にコピーしたい。
ファイルの中身は同じだけど、名前を変更して同じフォルダ内に
ファイルを作成したいということです。
ちなみに移動してきた時の始めのファイル名、#〇〇〇-〇は必ずこの形です。
なので、頭のシャープと-1以降の文字を削除して
〇〇〇の手前につける文字と、-〇以降につける文字が指定できれば完璧です。
このようなことができるかわかりませんが、よろしくお願いします。


よろしくお願いします。

Option Explicit
'Excel 2013 Later Japenese Version Available
'REF:
'REF:
'''///---定数の設定Set Enumuragion---///'''
Const PWD="aaaaa"
Const msoLanguageIDInstall = 1
'''///---変数の宣言---///'''

Dim objArgs, I , strFile
Dim objFile, objFolder,objPath,strScr
Dim xlApp,Wb
Dim objWShell : Set objWShell = Createobject("WScript.Shell")
Dim FSO : Set FSO = Createobject("Scripting.FileSystemObject")

'''///---ファイル処理開始 Start Document File Conversion---///'''
Set objArgs = Wscript.Arguments
For I = 0 to objArgs.Count-1
set objFile = FSO.GetFile(cstr(objArgs(I)))
If Lcase(Left(FSO.GetExtensionName(objFile.Path) ,4) )="xlsx" Then
Set xlApp =CreateObject("Excel.Application")
If xlApp.Version < 14 Then xlApp.Quit: Set xlApp = Nothing:wscript.Quit
xlApp.DisplayAlerts=False
xlApp.Visible = False
set wb=xlapp.WorkBooks.Open(objFile.Path,0,false,,PWd,,True,,false,false,,true,true)
if wb.HasPassword=true then
wb.Saveas objFile.Path,,"","",False
else
wb.Saveas objFile.Path,,Pwd,"",False
End if

Dim n
n = wb.Worksheets(1).Range("E5").Value & "_" & wb.Name
wb.close
FSO.GetFile(objFile.Path).Name = n

If Mid(objFile.name, 5, 2) = "-1" Then
FSO.MoveFile objFile.path, "F:\A\"
Else
MsgBox objFile.Name & " 該当せず"
End If

set wb=nothing
End If
Next
xlApp.DisplayAlerts=True
xlApp.Quit
set xlApp = Nothing

投稿日時 - 2019-01-11 13:20:32

QNo.9576598

すぐに回答ほしいです

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

修正
Else
MsgBox objFile.Name & " 該当せず"
Wscript.Quit
End If
↓↓↓↓↓
Else
MsgBox objFile.Name & " 該当せず"
Wscript.Quit
End If

投稿日時 - 2019-01-11 14:35:14

お礼

完璧です。こんなことができるとは感動です。
ありがとうございました。

投稿日時 - 2019-01-11 16:00:04

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

If Mid(objFile.name, 5, 2) = "-1" Then
FSO.MoveFile objFile.path, "F:\A\"
Else
MsgBox objFile.Name & " 該当せず"
End If
↓↓↓↓
Dim MovePath
If Mid(objFile.name, 5, 2) = "-1" Then
MovePath = "F:\A\"
ElseIf Mid(objFile.name, 5, 2) = "-2" Then
MovePath = "F:\B\"
Else
MsgBox objFile.Name & " 該当せず"
End If
FSO.CopyFile objFile.path, MovePath & "ABC" & Mid(objFile.Name,2, 5) & "_DEFG.xlsx"
FSO.MoveFile objFile.path, MovePath

投稿日時 - 2019-01-11 14:08:56

あなたにオススメの質問