| |
先日はお世話になりました。
ひとつお伺いしたいのですが、下記コードの※間で
「移動後フォルダ、移動前フォルダが存在するもの
且つ、移動前フォルダにファイルが入っているとき」
の条件で、移動前フォルダが無い時に「問題あり」と明記したいのですが
ご教授頂けませんでしょうか？
Sub フォルダ移動()
Dim myFso As Object
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim c As Range
Dim oFold As String
Dim nFold As String
Dim fName As String
Dim i As Long
Dim j As Long
Dim mySuffix As String
Dim myPeriod As String
Dim myFile As Object
Dim Fold_C As Object
Dim Fold_L As Variant
Dim prt As Integer
Dim cnt As Long
prt = MsgBox("記録廃棄前一次保管フォルダに移動しますか？", _
vbYesNo + vbInformation, "記録廃棄前一次保管フォルダ")
Select Case prt
Case vbYes
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("記録廃棄結果_３年")
Set sh2 = Sheets("一覧表")
mySuffix = sh1.Range("J14").Value
myPeriod = sh1.Range("J16").Value
For Each c In sh2.Range("B11", sh2.Range("B" & sh2.Rows.Count).End(xlUp))
'myPrefix = c.Value
i = c.Row
fName = ""
'一覧表Ｈ列に１年と記入あるものだけ
If sh2.Cells(i, "H").Value = myPeriod Then
'記録廃棄結果にハイパーリンクがあるとき
If sh1.Range("J10").Hyperlinks.Count > 0 Then
oFold = sh1.Range("J10").Hyperlinks(1).Address
'一覧表F列にハイパーリンクがあるとき
If sh2.Cells(i, "F").Hyperlinks.Count > 0 Then
nFold = sh2.Cells(i, "F").Hyperlinks(1).Address
'移動後フォルダ、移動前フォルダが存在するもの
'且つ、移動前フォルダにファイルが入っているとき
※ If myFso.FolderExists(oFold) And _
myFso.FolderExists(nFold & "\" & mySuffix) And _
myFso.GetFolder(nFold & "\" & mySuffix) _
※ .Files.Count > 0 Then
j = i
'移動後フォルダ内のサブフォルダを取得
Set Fold_C = myFso.GetFolder(oFold).SubFolders
'サブフォルダをループ
For Each Fold_L In Fold_C
'「mySuffix & "*"」に一致するものの連番の最大値
If Fold_L.Name Like mySuffix & "*" Then
If Val(Mid(Fold_L.Name, Len(mySuffix) + 1, _
Len(Fold_L.Name))) >= j Then
j = Val(Mid(Fold_L.Name, Len(mySuffix) + 1, _
Len(Fold_L.Name))) + 1
End If
End If
Next
'連番の最大値+1を付けてフォルダ作成
myFso.CreateFolder (oFold & "\" & mySuffix & j)
'移動前フォルダから作成したフォルダへファイル移動
myFso.MoveFile (nFold & "\" & mySuffix & "\*.*"), _
(oFold & "\" & mySuffix & j)
'移動前フォルダを削除
myFso.Deletefolder (nFold & "\" & mySuffix), Force:=True
'移動の判定
sh2.Cells(i, "AH").Value = "問題なし"
sh2.Cells(i, "AH").Font.ColorIndex = 1
cnt = cnt + 1
Else
sh2.Cells(i, "AH").Value = "問題あり"
sh2.Cells(i, "AH").Font.ColorIndex = 3
End If
End If
End If
End If
Next
Set myFso = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
MsgBox cnt & " 個のフォルダを移動しました。", vbInformation
Case vbNo
End Select
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
