| |
こんばんは
連番付けるなら移動より作成・削除の方が良さそうなので、
Sub ボタン1_Click()
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 myCheck As String
Dim myFile As Object
Dim Fold_C As Object
Dim Fold_L As Variant
myCheck = "３年"
Set myFso = CreateObject("Scripting.FileSystemObject")
Set sh1 = Sheets("記録廃棄結果")
Set sh2 = Sheets("一覧表")
mySuffix = sh1.Range("J14").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 = myCheck 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) Then
j = 0
Set Fold_C = myFso.GetFolder(oFold).SubFolders
For Each Fold_L In Fold_C
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
myFso.CreateFolder (oFold & "\" & mySuffix & j)
myFso.MoveFile (nFold & "\" & mySuffix & "\*.*"), _
(oFold & "\" & mySuffix & j)
myFso.Deletefolder (nFold & "\" & mySuffix), Force:=True
End If
End If
End If
End If
Next
Set myFso = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
End Sub
▼バッファー さん：
>お世話になります。
>ご指摘ありがとうございます。
>
>>連番（数字）は移動先のフォルダ内の「移動フォルダ名+連番」の数字の最大値+1を付けるという事でしょうか？
>とすると、移動する前にもうひとつ最大値を調べる処理を追加しないとダメですね。
>
>
>その通りです。数字の最大値+1を付けるということです。
|
|
ウッシ
- 12/10/14(日) 0:45 -
