Excel VBA質問箱 IV

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

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


1625 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   フォルダ移動マクロを作成していますが、移動ができず原因が
把握できなくなりました。どのようにすれば達成できますでしょうか?
お知恵を拝借頂ければ幸いです。


目的:
一覧表シートのF11行以降にハイパーリンクが設定されており、
ハイパーリンク先には幾つかフォルダがあります。
指定したフォルダだけを移動したい。(指定したフォルダ名は記録廃棄結果のJ14に指定されている)
移動先は記録廃棄結果J10のハイパーリンク先に移動させる。
なお、移動後に指定したフォルダには連番(数字)を語尾に付けたい。

質問の不備がございましたらご一報をお願いします。


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 mySuffix As String
  Dim myCheck As String
  Dim myFile As Object


  myCheck = "3年"

  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 = ""
    '一覧表H列に3年と記入あるものだけ
    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
            
            If myFso.fileExists(nFold & "\" & mySuffix) Then myFso.Deletefolder nFold & "\" & mySuffix, Force:=True
              myFso.MoveFolder nFold & "\" & mySuffix, oFold


          End If
        End If
      End If


    End If
 
  Next

  Set myFso = Nothing
  Set sh1 = Nothing
  Set sh2 = Nothing
 
  
End Sub

【72934】Re:フォルダ移動
回答  ウッシ  - 12/10/13(土) 12:10 -

引用なし
パスワード
   こんにちは

myFso.MoveFolder nFold & "\" & mySuffix, oFold & "\"

かな・・・

連番(数字)は移動先のフォルダ内の「移動フォルダ名+連番」の数字の最大値+1を付けるという事でしょうか?
とすると、移動する前にもうひとつ最大値を調べる処理を追加しないとダメですね。


▼バッファー さん:
>フォルダ移動マクロを作成していますが、移動ができず原因が
>把握できなくなりました。どのようにすれば達成できますでしょうか?
>お知恵を拝借頂ければ幸いです。
>
>
>目的:
>一覧表シートのF11行以降にハイパーリンクが設定されており、
>ハイパーリンク先には幾つかフォルダがあります。
>指定したフォルダだけを移動したい。(指定したフォルダ名は記録廃棄結果のJ14に指定されている)
>移動先は記録廃棄結果J10のハイパーリンク先に移動させる。
>なお、移動後に指定したフォルダには連番(数字)を語尾に付けたい。
>
>質問の不備がございましたらご一報をお願いします。
>
>
>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 mySuffix As String
>  Dim myCheck As String
>  Dim myFile As Object
>
>
>  myCheck = "3年"
>
>  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 = ""
>    '一覧表H列に3年と記入あるものだけ
>    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
>            
>            If myFso.fileExists(nFold & "\" & mySuffix) Then myFso.Deletefolder nFold & "\" & mySuffix, Force:=True
>              myFso.MoveFolder nFold & "\" & mySuffix, oFold
>
>
>          End If
>        End If
>      End If
>
>
>    End If
> 
>  Next
>
>  Set myFso = Nothing
>  Set sh1 = Nothing
>  Set sh2 = Nothing
> 
>  
>End Sub

【72936】Re:フォルダ移動
発言  バッファー  - 12/10/13(土) 16:55 -

引用なし
パスワード
   お世話になります。
ご指摘ありがとうございます。

>連番(数字)は移動先のフォルダ内の「移動フォルダ名+連番」の数字の最大値+1を付けるという事でしょうか?
とすると、移動する前にもうひとつ最大値を調べる処理を追加しないとダメですね。


その通りです。数字の最大値+1を付けるということです。

【72937】Re:フォルダ移動
回答  ウッシ  - 12/10/14(日) 0:45 -

引用なし
パスワード
   こんばんは

連番付けるなら移動より作成・削除の方が良さそうなので、

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 = "3年"
  
  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 = ""
    '一覧表H列に3年と記入あるものだけ
    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を付けるということです。

【72945】Re:フォルダ移動
発言  バッファー  - 12/10/15(月) 7:46 -

引用なし
パスワード
   お世話になります。

動作確認したところ問題なく、理想通りでした。

2点ほどお伺いしたいのですが、まず追加して頂いた箇所の処理の解説を
して頂ければ今後の参考になるのでよろしくお願いします。


>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


次に移動先フォルダにフォルダを作成する箇所で
作成する前に移動前のフォルダにファイルが存在するか確認してから上記の
作業を実行したいのですが、下記のように追加したのですが、
動作しませんでした。


追加: If myFso.FileExists(nFold & "\" & mySuffix) Then

>myFso.CreateFolder (oFold & "\" & mySuffix & j)
>   myFso.MoveFile (nFold & "\" & mySuffix & "\*.*"), _
>           (oFold & "\" & mySuffix & j)


>   myFso.Deletefolder (nFold & "\" & mySuffix), Force:=True
追加: End If

【72946】Re:フォルダ移動
回答  ウッシ  - 12/10/15(月) 9:41 -

引用なし
パスワード
   こんにちは

ファイルが無い場合も移動前フォルダを削除する場合はIF文の外に
「移動前フォルダを削除」するコードを出して下さい。

'移動後フォルダ、移動前フォルダが存在するもの
'且つ、移動前フォルダにファイルが入っているとき
If myFso.FolderExists(oFold) And _
    myFso.FolderExists(nFold & "\" & mySuffix) And _
      myFso.GetFolder(nFold & "\" & mySuffix) _
        .Files.Count > 0 Then
  j = 0
  '移動後フォルダ内のサブフォルダを取得
  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
End If

【72955】Re:フォルダ移動
お礼  バッファー  - 12/10/16(火) 19:11 -

引用なし
パスワード
   大変理解しやすい解説に感謝いたします。
今後の参考になりました。
今回のコードをアレンジしながら学んでいきたいと思います。

【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

【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

こういう事でしょうか?

【73044】Re:フォルダ移動
お礼  バッファー  - 12/10/31(水) 21:08 -

引用なし
パスワード
   お世話になります。

早急な対応に感謝します。
以下のコードに変更し、問題なく動作しました。
また一つ勉強になりました。


If myFso.FolderExists(nFold & "\" & mySuffix) = False Then
              sh2.Cells(i, "AH").Value = "問題あり"
              sh2.Cells(i, "AH").Font.ColorIndex = 3

              ElseIf myFso.FolderExists(oFold) And _
                myFso.FolderExists(nFold & "\" & mySuffix) And _
                myFso.GetFolder(nFold & "\" & mySuffix) _
                  .Files.Count > 0 Then


            '移動の判定
            sh2.Cells(i, "AH").Value = "問題なし"
            sh2.Cells(i, "AH").Font.ColorIndex = 1
            cnt = cnt + 1
          End If

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