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("記録廃棄結果_3年")
      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 = ""
        '一覧表H列に1年と記入あるものだけ
        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 質問
【72934】Re:フォルダ移動 ウッシ 12/10/13(土) 12:10 回答
【72936】Re:フォルダ移動 バッファー 12/10/13(土) 16:55 発言
【72937】Re:フォルダ移動 ウッシ 12/10/14(日) 0:45 回答
【72945】Re:フォルダ移動 バッファー 12/10/15(月) 7:46 発言
【72946】Re:フォルダ移動 ウッシ 12/10/15(月) 9:41 回答
【72955】Re:フォルダ移動 バッファー 12/10/16(火) 19:11 お礼
【73042】Re:フォルダ移動 バッファー 12/10/30(火) 21:30 発言
【73043】Re:フォルダ移動 ウッシ 12/10/30(火) 23:40 回答
【73044】Re:フォルダ移動 バッファー 12/10/31(水) 21:08 お礼

9252 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free