Excel VBA質問箱 IV

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

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


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

11846 / 76734

←次へ　｜　前へ→


	【70417】Re:エクセルファイルの移動について

UO3 - 11/11/15(火) 12:09 -


	引用なし

	パスワード

▼ピッポさん：

要件に合っているかどうか、試してみてください。

Sub Sample2()
　　Dim myFso As Object
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim c As Range
　　Dim ans As String
　　Dim oFold As String
　　Dim nFold As String
　　Dim fName As String
　　Dim tName As String
　　Dim i As Long
　　Dim cnt As Long
　　
　　Dim myPrefix As String
　　Dim mySuffix As String
　　Dim myCheck As String
　　Dim myFile As Object
　　
　　Dim b As String
　　Dim e As String
　　mySuffix = "済"
　　myCheck = "毎月"
　
　　Set myFso = CreateObject("Scripting.FileSystemObject")
　　Set sh1 = Sheets("一覧表（フォーマット）")
　　Set sh2 = Sheets("元保管場所")
　
　　For Each c In sh2.Range("B2", sh2.Range("B" & sh2.Rows.Count).End(xlUp))
　
　　　　myPrefix = c.Value
　　　　i = c.Row
　　　　fName = ""
　　　　'一覧表　Ｅ列に　毎月　と記入あるものだけ
　　　　If sh1.Cells(i, "E").Value = myCheck Then
　　　　　　'元保管場所C列にハイパーリンクあるものだけ
　　　　　　If c.Offset(, 1).Hyperlinks.Count > 0 Then
　　　　　　　　oFold = c.Offset(, 1).Hyperlinks(1).Address
　　　　　　　　'一覧表C列にハイパーリンクあるものだけ
　　　　　　　　If sh1.Cells(i, "C").Hyperlinks.Count > 0 Then
　　　　　　　　　　nFold = sh1.Cells(i, "C").Hyperlinks(1).Address
　　　　　　　　　　'移動前フォルダ、移動後フォルダが存在するものだけ
　　　　　　　　　　If myFso.folderExists(oFold) And myFso.folderExists(nFold) Then
　　　　　　　　　　
　　　　　　　　　　　　For Each myFile In myFso.GetFolder(oFold).Files
　　　　　　　　　　　　　　e = LCase(myFso.getextensionname(myFile.Name))
　　　　　　　　　　　　　　b = myFso.getbasename(myFile.Name)
　　　　　　　　　　　　　　'xls のみ
　　　　　　　　　　　　　　If e = "xls" Then
　　　　　　　　　　　　　　　　'指定文字列から始まり、"済"でおわっているもののみ
　　　　　　　　　　　　　　　　If b Like myPrefix & "*" & mySuffix Then
　　　　　　　　　　　　　　　　　　fName = myFile.Name
　　　　　　　　　　　　　　　　　　'移動先ブック名の生成
　　　　　　　　　　　　　　　　　　tName = Left(b, Len(b) - Len(mySuffix)) & "." & e
　　　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　　　
　　　　With sh1.Cells(i, "I")
　　　　　　'移動前フォルダに指定のブックが存在した場合のみ
　　　　　　If Len(fName) > 0 Then
　　　　　　　　
　　　　　　　　If myFso.fileExists(nFold & "\" & tName) Then myFso.DeleteFile nFold & "\" & tName, Force:=True
　　　　　　　　myFso.MoveFile oFold & "\" & fName, nFold & "\" & tName
　　　　　　　　cnt = cnt + 1
　　　　　　　　.Value = "問題なし"
　　　　　　Else
　　　　　　　　.Value = "問題あり"
　　　　　　End If
　　　　End With
　　
　　Next
　
　　Set myFso = Nothing
　　Set sh1 = Nothing
　　Set sh2 = Nothing
　　
　　MsgBox cnt & " 個のファイルを「Svr→書庫」に移動しました。", vbInformation

End Sub

3 hits

▼

【70390】エクセルファイルの移動について ピッポ 11/11/12(土) 16:57