Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9252 / 76732

←次へ　｜　前へ→


	【73043】Re:フォルダ移動

ウッシ - 12/10/30(火) 23:40 -


	引用なし

	パスワード

こんばんは

もう内容を忘れてしまったのですが、多分

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
　　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　ElseIf myFso.FolderExists(nFold & "\" & mySuffix) = False Then
　　　　　　　　　　
　　　　　　　　　　　　　　　　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

こういう事でしょうか？

0 hits

▼

【72928】フォルダ移動 バッファー 12/10/13(土) 9:36