Excel VBA質問箱 IV

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

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


9253 / 76732 ←次へ | 前へ→

【73042】Re:フォルダ移動
発言  バッファー  - 12/10/30(火) 21:30 -

引用なし
パスワード
   先日はお世話になりました。

ひとつお伺いしたいのですが、下記コードの※間で
「移動後フォルダ、移動前フォルダが存在するもの
且つ、移動前フォルダにファイルが入っているとき」
の条件で、移動前フォルダが無い時に「問題あり」と明記したいのですが
ご教授頂けませんでしょうか?


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
            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

4 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 お礼

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