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

質問

• VBAを使用して、(VBA)bat処理の結果が正しくないという問題があります。
• 具体的には、指定ディレクトリにBATファイルをコピーし、フォルダーを削除してからフォルダー名を変更する処理が正しく動作しないようです。
• 原因を調査して修正方法を教えていただきたいです。

回答No.6

kkkkkm

「ファイルやフォルダの操作もVBAで」
はNo2で指摘されてましたね。
No4は完無視してください。

補足

以下に仮のコードを作成してみました。
（過去教えてもらったコードの組み合わせ）

「'フォルダー内のフォルダー数」までは、うまく処理されていますが

「'フォルダー内のフォルダーを書き出す」が最後の１個しか書き出されていません。
原因は何でしょうか　？
---------------------------------------
Sub MooveUp_Directory()

Dim strPath As String
Dim intPathLen As Integer
Dim intR As Integer
Dim F As Variant
Dim obj As WshShell
Dim sPath As String
Dim folderPath As String
Dim CountFolder As Single
Dim strFlName As String

'Range("A5:F100").Clear

' フォルダーを自由に選べること。 参考：officeTANAKA
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

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

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

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

'batファイルの起動
sPath = mypath & "MoveUp_Directory.bat"
'MsgBox mypath

ChDir mypath
CreateObject("Wscript.Shell").Run sPath
'Call obj.Run(sPath, WaitOnReturn:=True)

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

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

'--- 含まれるフォルダ名を知りたいフォルダのパス ---'
folderPath = mypath

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

'--- フォルダ数を格納する変数 ---'
Dim n As Long
CountFolder = fso.GetFolder(folderPath).SubFolders.Count
MsgBox CountFolder

'フォルダー内のフォルダーを書き出す
Range(Cells(1, "A"), Cells(500, "A")).ClearContents

strFlName = Dir(mypath & "*", vbDirectory)
MsgBox strFlName
Do While strFlName <> ""
If Replace(strFlName, ".", "") <> "" Then
Cells(1, "A") = strFlName
intR = intR + 1
End If
strFlName = Dir
Loop

End Sub

'フォルダー名を元に戻す
Sub 指定位置から文字列抜き出し()

Dim MojiSuu As Single
Dim KokoKara As Variant

Dim i As Single
Dim Nukidashi As String
Dim EndRow As Single

With Sheets("DATA")
EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To EndRow
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
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 =