(VBA)bat処理の結果がおかしい

質問

以下の1)から5)までをVBAで行いたいのですが
１）、２）までのコードはネットを参考に作成したのですが
　２）の結果が￥tempに書き出されませんでした。
　　（C:¥に直接書き出される）

原因は何でしょうか　？
　（コードの修正をお願いします。）

以下は、行いたい事のイメージ。--------------------------------------------------
1)指定ディレクトリにディレクトリ(C:\)に保存した
　　BATファイル(aa.bat)をコピーする

2)指定ディレクトリ内でaa.batを起動する
3)指定ディレクトリーに最初から存在したフォルダーを削除する
4)aa.batによって作成されたフォルダーを最初のフォルダー名に変名する
5)aa.batをコピー先から削除する

例：指定ディレクトリをC:¥temp、aa.batをC:\tempにコピーしたと
　C:¥temp¥AA
　C:¥temp\AA￥subAA
　 C:\temp\aa.bat

aa.batを\temp内で起動した後で　------＞を実施
　C:¥AA　　　 ------＞　削除
　C:¥AA_SUBAA　------> C:\AAに変名
　C:\temp\aa.bat　-----＞　削除

最終的に
　C:¥temp\AA

---------------------------------------
Sub Test()

Dim strPath As String
Dim intPathLen As Integer
Dim intR As Integer
Dim F As Variant
Dim obj As WshShell
Dim sPath

'Range("A5:F100").Clear

' フォルダーを自由に選べること。 参考：officeTANAKA
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
' MsgBox .SelectedItems(1)
If Len(.SelectedItems(1)) = 3 Then ' c:\の場合とサブフォルダーの場合
mypath = .SelectedItems(1)
Else
mypath = .SelectedItems(1) & "\"
End If
End If
End With

If mypath = Empty Then MsgBox "フォルダー名の指定をキャンセルしました。": Exit Sub

MyName = Dir(mypath, vbDirectory) ' 最初のフォルダ名を返します。

’Range("A2") = mypath 'コピー先フォルダーの指定

'BATファイルのコピー
FileCopy "C:\aa.bat", mypath & "aa.bat"

'batファイルの起動
sPath = mypath & "\aa.bat"
Set obj = New WshShell
Call obj.Run(sPath, WaitOnReturn:=True)

End Sub
-------------------------------------------------------------------
以下は、aa.batの内容です。

for /d %%i in (*) do (
pushd .
cd %%i
for /d %%j in (*) do ren "%%j" "%%i_%%j"
for /d %%k in (*) do ren "%%k" "../%%k"
popd
rd "%%i"
)
-------------------------------------------

回答No.5

kkkkkm · ベストアンサー

いつもながらの思い付きですが
'batファイルの起動
の前に
ChDir mypath
にしてみるとか

お礼

kkkkkさん、いつも回答をいただき感謝いたします。

>'batファイルの起動の前に
>ChDir mypath
>にしてみるとか

まさに、ディレクトリーをTemp内に移動して
batを実施すると思っていた処理が出来ました。

これから、他の処理を追加してみます。
一応、全ての処理が出来た時点でコードを明示したいと思います。
（明日には何とか形に出来るとおもいます。）

回答No.21

kkkkkm

次回から一つの質問が解決したらいったん締め切って、コードを整理してから新たに質問を出して下さい。

お礼

おかげさまでやっとやりたいことができました。
最後までお付き合い願いありがとうございます。

>次回から一つの質問が解決したらいったん締め切って、
>コードを整理してから新たに質問を出して下さい。

コードの整理が出来ていないのに
思った理想の完成の答えを求めて
　最初の質問から離れた追加の質問を次々として
　トピが長くなってしまいました。

次回からは、トピが解決したら終了としたいと思います。

回答No.20

kkkkkm

> そこで、「_」のセルのバックの色を変えて
>　（例えば、黄色）視認できるようにはできませんか　？

条件付き書式で設定してください。

補足

>条件付き書式で設定してください。

アドバイス感謝いたします。

Nubering3に
　下記を追加してうまく処理できました。

'条件付き書式。セルの値が「_」の場合
With Worksheets("Number").Range("A1:AS20").FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="_")
'背景色をシャルトルーズにする
.Interior.Color = XlRgbColor.rgbChartreuse
End With

回答No.19

kkkkkm

> fso.DeleteFolder MyPath & DelSubF
>
> でいけるのではないでしょうか。

といったのは

Set fso = Nothing
より前にそのコードがあったからで

今回は開放より後に

fso.MoveFolder OldFolder, NewFolder

を使ってるからエラーになっているのではないでしょうか。

Dimも最初にあったり途中にあったりしてますし、ひとつ機能を追加したらその時点で一度コードを整理したほうがいいのではないでしょうか。

お礼

お世話をおかけしていますが、
　エラーの原因が判明しました。

>fso.MoveFolder OldFolder, NewFolder
>を使ってるからエラーになっているのではないでしょうか。

全く、そのとうりで

ObjFSO.MoveFolder OldFolder, NewFolder
とすべきを

fso.MoveFolder OldFolder, NewFolder
とNothingで開放したfsoを利用しようとしていました。

>ひとつ機能を追加したらその時点で一度コードを整理したほうがいいのではないでしょうか。

コードの整理が出来ていないのに答えを求めて
　先を急いで沼に迷い込んでしまいました。

--------------------
どうにか、コードは希望に合った完成形に近づきましたが
最後に以下のコードで
　何番目から抜き出すかを指定するのに
今回は、「_」を探したのですがフォルダー名が長くなると
　「_」を探すのがナンバリングしていてもすぐには見つかりません。

そこで、「_」のセルのバックの色を変えて
　（例えば、黄色）視認できるようにはできませんか　？

コードを何回も走らせていると追加で
　　　　　やりたいことが増えてしまいました。
--------------------------------------------------------------

'フォルダー名を変更する
'指定位置から文字列抜き出し()

With Sheets("DATA")
EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
For I = 2 To EndRow Step 2
Nubering3 (I)
KokoKara = Application.InputBox(prompt:="何番目から抜き出すか？　数値を入力してください", Title:="指定位置（数値入力）", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
.Activate
MojiSuu = Len(.Range("A" & I))
Nukidashi = Mid(.Range("A" & I), KokoKara, MojiSuu)
.Range("B" & I) = Nukidashi
Next I
End With

Sub Nubering3(ByVal DataRow As Long)

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim I As Long, j As Long, WRow As Long, WColumn As Long
Dim uRows As Range, uRange As Range
Dim font1 As Font

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")
Set uRows = Ws2.Rows(1)
Set uRange = Ws2.Range("A2")

'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア）
Ws2.Range("A1:XX100").Clear

Application.ScreenUpdating = False
WRow = 1: WColumn = 1
For j = 1 To Len(Ws1.Cells(DataRow, "A").Value)
Ws2.Cells(WRow, WColumn).Value = j
Ws2.Cells(WRow + 1, WColumn).Value = Mid(Ws1.Cells(DataRow, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, WColumn))
Set uRows = Union(uRows, Ws2.Rows(WRow))
If j Mod 40 = 0 Then
WRow = WRow + 3
WColumn = 1
Else
WColumn = WColumn + 1
End If
Next

'Numeling 大文字、中央揃え
uRows.HorizontalAlignment = xlCenter
uRows.Font.Bold = True
'フォントサイズ指定
uRows.Font.Size = 9

'分割文字中央揃え罫線外枠
uRange.HorizontalAlignment = xlCenter
uRange.Borders.LineStyle = xlContinuous
'フォントサイズ指定
'uRange.Font.Name = "HGP創英角ポップ体"
uRange.Font.Size = 9

'セル幅を見やすく
Ws2.Range("A1:xx100").ColumnWidth = 3

Application.ScreenUpdating = True
Ws2.Activate

Set Ws1 = Nothing
Set Ws2 = Nothing
Set uRows = Nothing
Set uRange = Nothing

End Sub

回答No.18

kkkkkm

エラーの場合、エラーメッセージで検索して対処方法を探してみてください。

回答No.17

kkkkkm

OldFolder = FolderName & "\" & Ws01.Cells(I, "A")
MsgBox "古いフォルダー名　" & OldFolder
NewFolder = FolderName & "\" & Ws01.Cells(I, "B")
MsgBox "新しいフォルダー名　" & NewFolder

この結果が間違っているのですから
文字列を結合する一歩手前の
FolderName
Ws01.Cells(I, "A")
Ws01.Cells(I, "B")
をそれぞれ見て確認するしかないです。
.Valueは付けたほうがいいと思います。
Ws01.Cells(I, "A").Value
Ws01.Cells(I, "B").Value

補足

￥が２つ付く件は、下記が原因でした。

OldFolder = FolderName & "\" & Ws01.Cells(I, "A")
NewFolder = FolderName & "\" & Ws01.Cells(I, "B")

わざわざ　& "\" &　で￥を無駄に付加していました。

下記に変更してmsgboxは正常に表示されるようになりました。

OldFolder = FolderName & Ws01.Cells(I, "A")
NewFolder = FolderName & Ws01.Cells(I, "B")

Valueは付けたほうがいいとのアドバイスで
　さらに下記に変更しました。

OldFolder = FolderName & Ws01.Cells(I, "A").value
NewFolder = FolderName & Ws01.Cells(I, "B").value

しかし、エラーは解消しませんでした。
（オブジェクト変数または With ブロック変数が設定されていません。(エラー番号：91)）

回答No.16

kkkkkm

Set ObjFSO = CreateObject("Scripting.FileSystemObject")

すでに

Set fso = CreateObject("Scripting.FileSystemObject")

がありますからfso使って

fso.DeleteFolder MyPath & DelSubF

でいけるのではないでしょうか。

お礼

コードが長すぎて4000文字の制限で尻切れ状態になりました。

不足分を追加します
--------------------------------------------------
MsgBox "新しいフォルダー名　" & NewFolder

'MsgBox NewFile

'ChDir MyPath

'ファイル名を変更します。
fso.MoveFolder OldFolder, NewFolder

Next I

End Sub

Sub Nubering3(ByVal DataRow As Long)

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim I As Long, j As Long, WRow As Long, WColumn As Long
Dim uRows As Range, uRange As Range
Dim font1 As Font

Set Ws1 = Sheets("DATA")
Set Ws2 = Sheets("Number")
Set uRows = Ws2.Rows(1)
Set uRange = Ws2.Range("A2")

'Numberシートの初期化（全体=数式・文字・書式・コメント全てをクリア）
Ws2.Range("A1:XX100").Clear

Application.ScreenUpdating = False
WRow = 1: WColumn = 1
For j = 1 To Len(Ws1.Cells(DataRow, "A").Value)
Ws2.Cells(WRow, WColumn).Value = j
Ws2.Cells(WRow + 1, WColumn).Value = Mid(Ws1.Cells(DataRow, "A").Value, j, 1)
Set uRange = Union(uRange, Ws2.Cells(WRow + 1, WColumn))
Set uRows = Union(uRows, Ws2.Rows(WRow))
If j Mod 40 = 0 Then
WRow = WRow + 3
WColumn = 1
Else
WColumn = WColumn + 1
End If
Next

'Numeling 大文字、中央揃え
uRows.HorizontalAlignment = xlCenter
uRows.Font.Bold = True
'フォントサイズ指定
uRows.Font.Size = 9

'分割文字中央揃え罫線外枠
uRange.HorizontalAlignment = xlCenter
uRange.Borders.LineStyle = xlContinuous
'フォントサイズ指定
'uRange.Font.Name = "HGP創英角ポップ体"
uRange.Font.Size = 9

'セル幅を見やすく
Ws2.Range("A1:xx100").ColumnWidth = 3

Application.ScreenUpdating = True
Ws2.Activate

Set Ws1 = Nothing
Set Ws2 = Nothing
Set uRows = Nothing
Set uRange = Nothing

End Sub

補足

現在コード作成中です。
（変な点などあればアドバイスお願いします。）

最終部に仮のコードを作成しましたが
最後の以下でエラーがでました。

　　'ファイル名を変更します。
　　　 fso.MoveFolder OldFolder, NewFolder

　　オブジェクト変数または With ブロック変数が設定されていません。(エラー番号：91)

以下のようにチェックの為MsgBoxを仮に記載しました。

OldFolder = FolderName & "\" & Ws01.Cells(I, "A")
MsgBox "古いフォルダー名　" & OldFolder
NewFolder = FolderName & "\" & Ws01.Cells(I, "B")
MsgBox "新しいフォルダー名　" & NewFolder

MsgBoxが表示されて
古いフォルダー名　C:temp\\AA_AA
新しいフォルダー名　C:\temp\\AA
とtemp￥￥と￥￥が2個表示されているのでミスがあるのは間違いないのですが
これが原因で変名出来ないのでしょうか　？

--------------------------------------------
>fso使って
>fso.DeleteFolder MyPath & DelSubF
>でいけるのではないでしょうか。

以前setは使用後は、Nothingで開放しないとコメントを頂いたので
使用後は、開放するようにしているので
無駄な宣言（2重手間）が発生してしまいました。

すいませんが、
　とりあえず、現状のコードが一応の目途が立った後で
　ご指摘の件は、検討します。

私の現状では、2つ同時に検討するのは　能力不足です。

------------------------------------------
Option Explicit

Sub MooveUp_Directory()

Dim IntR As Integer
Dim Obj As WshShell
Dim SPath As String
Dim FolderPath As String
Dim SubF As Object
Dim DelSubF As String
Dim ObjFSO As Object
Dim MyF As Object
Dim Ws01 As Worksheet
Dim lRow As Single
Dim FolderName, OldFolder, NewFolder As String

Dim MojiSuu As Single
Dim KokoKara As Variant

Dim I As Single
Dim Nukidashi As String
Dim EndRow As Single

Dim str As String '文字列
Dim cnt As Long '文字列が全部で何文字か
Dim n As Long '何文字削除するかを指定

' フォルダーを選択(自由に選べること.)
' MyPath
Dim MyPath As String

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
If Len(.SelectedItems(1)) = 3 Then ' c:\の場合とサブフォルダーの場合
MyPath = .SelectedItems(1)
Else
MyPath = .SelectedItems(1) & "\"
End If
End If
End With

If MyPath = Empty Then MsgBox "フォルダー名の指定がキャンセルしました。": Exit Sub

'BATファイルのコピー
FileCopy "C:\MoveUp_Directory.bat", MyPath & "MoveUp_Directory.bat"

'batファイルの起動
SPath = MyPath & "MoveUp_Directory.bat"
Set Obj = New WshShell

ChDir MyPath
Call Obj.Run(SPath, WaitOnReturn:=True)

Set Obj = Nothing

'フォルダー内の不要ファイルの削除
Kill MyPath & "*.bat"

'フォルダー内のフォルダー名

FolderPath = MyPath '--- 含まれるフォルダの数を知りたいフォルダのパス ---'

'--- ファイルシステムオブジェクト ---'
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

'フォルダー内のフォルダーを書き出す
Set MyF = fso.GetFolder(FolderPath) ' 含まれるフォルダ名を知りたいフォルダを返します。
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
IntR = 1
For Each SubF In MyF.SubFolders 'サブフォルダーを取得します。

If InStr(SubF.Name, "_") > 0 Then
'MsgBox SubF.Name
DelSubF = Left(SubF.Name, InStr(SubF.Name, "_") - 1)
'Cells(IntR, "B") = MyPath & DelSubF
ObjFSO.DeleteFolder MyPath & DelSubF
End If

Cells(IntR, "A") = SubF.Name
IntR = IntR + 1
Next

Set fso = Nothing
Set MyF = Nothing
Set ObjFSO = Nothing

'フォルダー名を変更する
'指定位置から文字列抜き出し()

With Sheets("DATA")
EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
For I = 2 To EndRow Step 2
Nubering3 (I)
KokoKara = Application.InputBox(prompt:="何番目から抜き出すか？　数値を入力してください", Title:="指定位置（数値入力）", Type:=1)
If TypeName(KokoKara) = "Boolean" Then
MsgBox "数値以外が入力されたので終了します。"
Exit Sub
End If
.Activate
MojiSuu = Len(.Range("A" & I))
Nukidashi = Mid(.Range("A" & I), KokoKara, MojiSuu)
.Range("B" & I) = Nukidashi
Next I
End With

Sheets("Number").Range("A1:XX100").Clear

'指定したフォルダー名を変更します。
Set ObjFSO = CreateObject("Scripting.FileSystemObject")

Set Ws01 = Worksheets("DATA")

FolderName = MyPath 'ターゲットフォルダー

lRow = Ws01.Cells(Rows.Count, "A").End(xlUp).Row 'A列の最終行を取得

For I = 2 To lRow Step 2 '最終行まで繰り返す

OldFolder = FolderName & "\" & Ws01.Cells(I, "A")
MsgBox "古いフォルダー名　" & OldFolder
NewFolder = Folde

回答No.15

kkkkkm

> エラー原因は何でしょうか　？

B列に正しいフルパスの削除対象フォルダ名が出力されていませんから
Kill MyPath & DelSubF
実行は早すぎます。
Killを使ったことなかったので調べたらフォルダ削除できないということで
Kill
は
RmDir
どちらにしても
B列に正しいフルパスの削除対象フォルダ名が出力されたから、実行するようにしてください。

2行目なら(Cドライブ真下にtempがあるなら)
２ AA＿AA C:\temp\AA
が正しくなります。
AA＿AAの「＿」が全角ですが本来は半角ですよね。

お礼

>２ AA＿AA C:\temp\AA
>AA＿AAの「＿」が全角ですが本来は半角ですよね。

すいません。
　C:¥を加えるのを忘れていました。
　AA＿AAの「＿」は、半角です。
　　　ひらがな変換モードでそのまま全角を使ってしまいました。

Cells(IntR, "B") = MyPath & DelSubF
の結果は、正しいディレクトリー構造を表示しています。

教えてもらって
　killでは、フォルダーは削除できないと言う事実を初めて知りました。

RmDirに変更してもエラーが出るので調べてみると

　「RmDir ステートメント は、ディレクトリまたはフォルダ内が空で無い場合
　　削除しようとするとエラーが発生します
　ディレクトリまたはフォルダを中のファイルごと削除したい場合には、
　FileSystemObject オブジェクト の DeleteFolder メソッド を使用する」

との事なので以下のように変更しました。

Dim ObjFSO As Object　＜------　追加

'フォルダー内のフォルダーを書き出す
Set MyF = fso.GetFolder(FolderPath) ' 含まれるフォルダ名を知りたいフォルダを返します。
Set ObjFSO = CreateObject("Scripting.FileSystemObject")　　　＜------　追加
IntR = 1
For Each SubF In MyF.SubFolders 'サブフォルダーを取得します。

If InStr(SubF.Name, "_") > 0 Then
MsgBox SubF.Name
DelSubF = Left(SubF.Name, InStr(SubF.Name, "_") - 1)
Cells(IntR, "B") = MyPath & DelSubF
ObjFSO.DeleteFolder MyPath & DelSubF　　＜------　変更
End If

Cells(IntR, "A") = SubF.Name
IntR = IntR + 1
Next

Set fso = Nothing
Set MyF = Nothing
Set ObjFSO = Nothing　　＜------　追加

おかげさまで
　必要ないフォルダーの削除が出来ました。

後AA_AAをAAに変更する工程が残っています。
今からコードを作成していきますので
　少し時間をください。

回答No.14

kkkkkm

Dim DelSubF As String
になっているでしょうか。

お礼

ご迷惑をおかけしてすいません。
　ミスがありました。

>Dim DelSubF As String
>になっているでしょうか。

Dim SubF As Object
なので
Dim DelSubF As Object
としていました。

指摘を受けてStringに変更して
　エラーは出なくなりました。

Cells(intR, "B") = mypath & DelSubF
を記載しているので

DATAシートで以下のように表示されているのを確認しました

A B
１ AA
２ AA＿AA \temp\AA_AA
３ BB
４ BB＿BB \temp\BB_BB
５ CC
６ CC＿CC \temp\CC_CC
----------------------------

Kill MyPath & DelSubF
をコードに追加して実行すると
　　ファイルが見つかりません。
　　　（エラー　53）
がでました。

エラー原因は何でしょうか　？

回答No.13

kkkkkm

If InStr(SubF, "_") > 0 Then

SubF.Nameになっていません。

DelSubF.Name

.Nameはいいりません。

Kill MyPath & DelSubF
は
正しくフォルダ名ができているか確認してから実行したほうがいいのではないでしょうか

Debug.Print mypath & DelSubF
もしくは
Cells(intR, "B") = mypath & DelSubF

補足

エラー処理が上手くいきません。

No.13の修正アドバイスを受けて
　下記のように修正しましたが
　又同じ場所で同じエラーが発生します。

----------------------------------
フォルダー内のフォルダーを書き出す
Set MyF = fso.GetFolder(FolderPath) ' 含まれるフォルダ名を知りたいフォルダを返します。

IntR = 1
For Each SubF In MyF.SubFolders 'サブフォルダーを取得します。
Stop

If InStr(SubF.Name, "_") > 0 Then
MsgBox SubF.Name
DelSubF = Left(SubF.Name, InStr(SubF.Name, "_") - 1)
'Kill MyPath & DelSubF.Name
Cells(IntR, "B") = MyPath & DelSubF
End If

Cells(IntR, "A") = SubF.Name
IntR = IntR + 1
Next
------------------------
ターゲットのフォルダーが\tempだと
マクロをSTOPで途中止めた時点で
temp\の中には以下のフォルダーが存在します。

AA
AA＿AA
BB
BB＿BB
CC
CC＿CC

STOP以後F8でステップインで1行ずつトレースすると
最初のAAは、A1セルに書き出されます。

次の、AA＿AAはIF分で処理されるために
　DelSubF = Left(SubF.Name, InStr(SubF.Name, "_") - 1)
に処理が移動しますがここでエラーが発生。

回答No.12

kkkkkm

> 　下記にように変更してみましたがエラーが発生します
> オブジェクト変数または With ブロック変数が設定されていません。(エラー番号：91)

SubF.Name

でフォルダ名になりますので試してみてください。

補足

>SubF.Name
>でフォルダ名になりますので試してみてください。

以下のように変更してみましたが、同じ場所で同じエラーが発生します。
修正するところが違うのでしょうか　？

If InStr(SubF, "_") > 0 Then
MsgBox SubF.Name
DelSubF.Name = Left(SubF.Name, InStr(SubF.Name, "_") - 1)
Kill MyPath & DelSubF.Name
End If