- ベストアンサー
エクセルVBA 名前の競合と一括移動
フォルダの中にある複数のサブフォルダを一度に移動先フォルダに移動させたいと考えています。いろいろ参考にして、下のようにコードを用意しています。これで移動前のフォルダを指定した後、移動後のフォルダをしていして、移動することができました。ただしこれだと一つ一つのフォルダについて選択しなくてはならず、理想とはいえません。 改良して次の点を付加したいのですが、どのようにするのかわからずつまずいています。 (条件) ・移動先のフォルダの中にはサブフォルダがある階層。 ・フォルダ名は英数字6～9文字 追加したい点は 1.一度に「移動前」のフォルダ内のサブフォルダを「移動先」フォルダの中に移動する。 2.名前が競合した場合は、「移動先」フォルダの中にすでにあるサブフォルダの中に移動する という機能を付加したいのですが、行き詰っています。お知恵を拝借できないでしょうか？ Sub FolderMove() Dim SourcFolderSpec, DestFolderSpec As String Dim SourcFolder_Object, DestFolder_Object As Object Dim FileNamePath As Variant SourcFolderSpec = FolderPath If SourcFolderSpec = "" Then End End If DestFolderSpec = FolderPath If DestFolderSpec = "" Then End End If Set SourcFolder_Object = CreateObject _ ("Scripting.FileSystemObject").GetFolder(SourcFolderSpec) DestFolderSpec = DestFolderSpec & "\" SourcFolder_Object.Move DestFolderSpec End Sub
- reprogress
- お礼率45% (40/87)
- オフィス系ソフト
- 回答数4
- ありがとう数3
- みんなの回答 （4）
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (3)
- Wendy02
- ベストアンサー率57% (3570/6232)
こんにちは。 ご説明の意図に見えない部分がありますが、こんな感じはどうかな？ >2.名前が競合した場合は、「移動先」フォルダの中にすでにあるサブフォルダの中に移動する ただし、一回限りです。中身は、ショートネームで実行されています。 Win 9x 系は不可（変更は可能） '------------------------------------- Sub MoveDirectries() Dim SourceFolder As String Dim SourceDir As String Dim DestFolder As String Dim DestDir As String Dim ArDirs() As String Dim FOLname As String Dim i As Integer Dim v As Variant Dim ret As Integer 'Win 2000以上 Const MYCMD1 As String = "CMD /C MOVE " '末尾は半角スペースを開ける SourceFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ（元）\ は必ず付ける DestFolder = ActiveWorkbook.Path & "\" 'ベースのフォルダ（先）\ は必ず付ける SourceDir = SourceFolder & "Test1Fold\" '末尾に\ は付けなくてよい DestDir = DestFolder & "Test1AFold\" '最終フォルダに \ があったら省く If Right(SourceDir, 1) = "\" Then SourceDir = Mid$(SourceDir, 1, Len(SourceDir) - 1) If Right(DestDir, 1) = "\" Then DestDir = Mid$(DestDir, 1, Len(DestDir) - 1) ReDim Preserve ArDirs(i) FOLname = Dir(SourceDir & "\", vbDirectory) Do While FOLname <> "" If FOLname <> "." And FOLname <> ".." Then If (GetAttr(SourceDir & "\" & FOLname) And vbDirectory) = vbDirectory Then ReDim Preserve ArDirs(i) ArDirs(i) = FOLname i = i + 1 End If End If FOLname = Dir Loop 'フォルダの下のフォルダを作るのは一回のみ For Each v In ArDirs() If Dir(DestDir & "\" & v, vbDirectory) = "" Then ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & """") ElseIf Dir(DestDir & "\" & v & "\" & v, vbDirectory) = "" Then ret = Shell(MYCMD1 & """" & SourceDir & "\" & v & """" & " " & """" & DestDir & "\" & v & """") End If Next v End Sub
補足
ありがとうございました。これはすごいですね。ためさせていただいたのですが、うまくいきました。 初めて聞く技がたくさんあり、少し調べたのですが、よくわかりませんでした。 >中身は、ショートネームで実行されています。 >Const MYCMD1 As String = "CMD /C MOVE " '末尾は半角スペースを開>ける この部分がまったくわかりません。どのようなことをしているのでしょうか？簡単で結構なので教えていただけると助かります。
- KenKen_SP
- ベストアンサー率62% (785/1258)
Windows の動作としては移動先に同名のフォルダがある場合、通常 ユーザーに判断を仰ぐか、または上書きします。 > 2.名前が競合した場合は、「移動先」フォルダの中にすでにある > サブフォルダの中に移動する この仕様だと、 > 「移動先」フォルダの中にすでにあるサブフォルダの中 に再度同名フォルダがある場合、さらに深い階層にフォルダを移動 させることになるのでしょうか？ Windows のパス長の制限に引っかかりそうですから、あまり現実的 ではないと思いますが.... 参考：Windows のファイル名長さの制限 ・Windows 9x 系 絶対パスを含めて 255 バイト ・Windows NT 系 全角半角に関わらず 255文字 まで ※厳密には 260文字まで予約されているが、エクスプローラ からは、255文字までにか入力できない この辺はどのようにお考えですか？
お礼
ファイル名長さの制限ということまでは考えていませんでした。まだまだです。ありがとうございました。
- kigoshi
- ベストアンサー率46% (120/260)
条件のなかの「移動先のフォルダの中にはサブフォルダがある階層」の意味が今一歩理解できていませんが。 とりあえず「移動」ではなくて「複写」して元を「削除」という手順ではいかがでしょう。 具体的には最後の１行 SourcFolder_Object.Move DestFolderSpec を SourcFolder_Object.Copy DestFolderSpec SourcFolder_Object.Delete にすると良いように思います。 ただし、同名のファイルがあったときは上書きされると思います。
お礼
ありがとうございます。参考になりました。
関連するQ&A
- FSOを使いサブフォルダのファイル操作
同じ階層のサブフォルダにxlsm入るが入っており、VBAによりモジュールを解放しようと試みています。 まずは、FSOを使ってサブフォルダにアクセスしようとしましたが、下から6行目でエラー（424 オブジェクトが必要です）が出てしまい、解決できませんので、ご教示いただけないでしょうか？ よろしくお願いします Sub DeleteMain() With Application.FileDialog(msoFileDialogFolderPicker) If Not .Show Then Exit Sub Call DeleteSub(folderPath:=.SelectedItems(1)) End With End Sub Sub DeleteSub(folderPath As String, Optional mycount As Long = 0) Dim fso As Object, myFolders As Object, myfile As Object Set fso = CreateObject("Scripting.FileSystemObject") Set myFolders = fso.GetFolder(folderPath).SubFolders For Each myfile In fso.GetFolder(folderPath).Files mycount = mycount + 1 ' Cells(mycount, 1) = myfile.Path Debug.Print myfile.Path Next For Each myFolders In fso.GetFolder(folder.Path).SubFolders Call DeleteSub(myFolder.Path, mycount) Next Set fso = Nothing Set myFolders = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
- テキストファイルをエクセルに移すマクロのことで？
以前、複数のテキストファイルをエクセルに移すマクロを教えてもらったのですが、 以下マクロですと、フォルダのパスを指定しないといけません。 今回教えてもらいたいのは、フォルダのパスを指定しなくてもよい方法です。 どういう事かと言うと、仮にディスクトップにフォルダがあるとします。 そのフォルダの中には、マクロが入っているエクセルシートとテキストが入っているフォルダです。 つまり、そのフォルダ内だけで、処理をしたいと考えています。 また、フォルダ名は、その時によって異なります。 今までは、以下の方法を使っていたのですが、ちょっと使いにくいと感じています。 申し訳ありませんが、どなたか教えていただけないでしょうか？ Sub Macro() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim FolderPath As String 'ここのアドレスをファイルが格納されているフォルダのパスに変えてください FolderPath = "C:\Users\・・・" Dim myFile As Object Dim i As Long i = 2 Dim myFolder As Object For Each myFolder In fso.GetFolder(FolderPath).SubFolders For Each myFile In fso.GetFolder(myFolder).Files Cells(i, 4).Value = myFolder Cells(i, 1).Value = myFile.Name Cells(i, 7).Value = fso.OpenTextFile(myFile.Path).ReadAll() i = i + 1 Next Next End Sub Private Sub CommandButton1_Click() End Sub
- ベストアンサー
- オフィス系ソフト
- ＥＸＣＥＬ ＶＢＡについて（再質問）
お世話になります。 EXCEL VBAで指定したフォルダのEXCELブックが１つでもオープンされているかどうか知りたいのですが、可能でしょうか。 という質問を行い、以下の回答をいただきました。 自分でテストしてみてできたと思ったのですが、 他の人が開いているのが分かりませんでした。 他の人がオープンしているかどうか知ることは可能でしょうか？ よろしくお願いします。 以下の回答といただきました。 －－－－－－－－－－－－－ ※[ツール]-[参照設定]で Microsoft Scripting Runtimeにチェック入れて下さい。 Dim Fso As New FileSystemObject 'ファイルシステムオブジェクト Dim xlBook As Workbook '開かれているブック Dim objFolder As Folder '調べるフォルダ Dim bOpenedBook As Boolean '開かれているかフラグ '調べるフォルダを「C:\tmp」とする。 Set objFolder = Fso.GetFolder("C:\tmp") bOpenedBook = False '今開かれているブックでループする。 For Each xlBook In Excel.Workbooks If Len(xlBook.Path) > 0 Then 'ブックが保存されているフォルダと調べるフォルダが一致するか？ If objFolder Is Fso.GetFolder(xlBook.Path) Then '一致すれば開かれている bOpenedBook = True Exit For End If End If Next '結果をメッセージボックスで表示 If bOpenedBook Then MsgBox "開かれています。" Else MsgBox "一つも開かれていません。" End If
- ベストアンサー
- Visual Basic
- ▲ExcelのVBA▼困っています
何度もVBAで質問させてもらい助けてもらっています。 懲りずにまた質問ですが… 下のプログラムは"●"が跳ね返るものなのですが… ●の後を■と▲が追うようなプログラムにするには なにを追加すればいいのでしょうか…？; どなたか教えて下さい;;お願いします;; Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim maru As String, yoko As String, tate As String Sub 描画() Cells(X, Y).Value = maru End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() maru = "●" X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub
- ベストアンサー
- その他（プログラミング・開発）
- Excel VBA ・・・教えてください
何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して １～２０の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず ２０の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub
- ベストアンサー
- その他（プログラミング・開発）
- エクセルVBAで、IEからコピーするには
エクセル2000,win2000,IE6です。 次のような、コードを書きました。 Sub t03ccc() Dim objIE As Object 'IE オブジェクト参照用 Dim objShell As Object 'Shell オブジェクト参照用 Dim objWindow As Object 'Window オブジェクト参照用 Set objShell = CreateObject("Shell.Application") For Each objWindow In objShell.Windows '起動中のタイトルを探して。 If Left(objWindow.document.Title, 7) = "Office系" Then Set objIE = objWindow 'オブジェクトを代入 Msg = "Office系" Exit For End If Next If Msg <> "Office系" Then MsgBox "・・・スクリーニング結果一覧・・・がありません" Exit Sub End If objIE.ExecWB 17, 0 'OLECMDID_SELECTALL = 17 全てを選択 objIE.ExecWB 12, 0 'OLECMDID_COPY = 12 コピー Sheets("Sheet3").Select Rows("1:200").ClearContents Range("A1").Select ActiveSheet.Paste '''' objIE.Quit Set objIE = Nothing Set objShell = Nothing Set objWindow = Nothing End Sub これで、エクセルとIEしか開いてないときは巧くいくのですが、 エクスプローラーを同時に開くと実行時エラー438が出ます。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- ドライブの中のファイル一覧（＆サイズ等）を作成するVBAを教えてください！！
ドライブの中フォルダーに関する情報を一覧表にして、どのフォルダーがドライブ容量を圧迫しているか調べたく、下記のVBAを書いてみたのですが、うまく走りません。 取得したい内容は、例えば、My Documentの中に入っている、Folder Name, Size, DateLastModifiedです。サブフォルダーがある場合は、さらにそのフォルダーの上記の情報も取得したいです。 *************************************************************** Sub FolderList() Dim fs As Object, fd As Object, f As Object Dim i As Integer Set fs = CreateObject("Scripting.FileSystemObject") Set fd = fs.GetFolder("C:\Documents and Settings\Ontario91") If f.Type Like "Folder*" Then i = i + 1 Cells(i, 1).Value = f.Name Cells(i, 2).Value = f.DatelastModified Cells(i, 3).Value = f.Size End If Range("A1").CurrentRegion.EntireColumn.AutoFit End Sub *************************************************************** VBA初心者なので、精通されている方たちには、かなり初歩的なコードだと思い、恥ずかしいのですが、質問させていただきます。お力添えよろしくお願い致します。
- ベストアンサー
- Windows XP
- vba pdfファイル順番に印刷
セルC5から、下にファイル名が入っています。上から順に印刷したいのですが、下記だとvbaが動かないです。 Dim z As Object Dim i As Long Dim f, p As String Set z=CreateObject("WScript.Shell") p=Application.ActivePrinter For i=5 To Range("C1").End(xlDown).Row f="C:¥フォルダパス" & Cells(i,1).Value & ".pdf" ここから、行ごとに進んだ時に、黄色くならず反応しませんでした↓ If Dir (f)<>""Then z.Run("Acrobat.exe /t" & f) ↓ここにとびました。 Else End if Next i Set z=Nothing End Sub それ以前に、adobe acrobatが、更新されてから動いていたバッチファイルですら反応しなくなりました Adobeの環境設定をネットで見た通り見直ししたりしたのですが、全く成功しません。フォルダ内のpdfファイルを、全て印刷するvba（Acrobat.exe)を記載しない方法は成功したのですが、どうすれば、上手くいきますか？ 教えていただきたいです。印刷の順番を指定したいです。 初心者なのでお手柔らかにお願いします。ちなみに動いているほうのvbaは下記です。 フォルダ内のファイルを全て印刷する、（順番関係なし）です。 Dim FolderPath As String Dim Filename As String Dim objShell As Object Dim objFolder As Object Dim objFile As Object FolderPath=ThisWorkbook.Path Set objShell=CreateObject("Shell.Application") Set objFolder=objShell.Namespace(ThisWorkbook.Path) For Each objFile In objFolder.items If Right(objFile.Name,4)=".pdf"Then objFolder.ParseName(objFile.Name) .InvokeVerbEx("print") End If Next objFile Set objFile=Nothing Set objFolder=Nothing Set objShell=Nothing End Sub 上記は全てネットから引用しています。 adobe acrobatを使うと反応しないので下記、上記に付け足ししたりして自身で初めて考えました。 Sub Test() Dim FolderPath As String Dim Filename As String Dim objShell As Object Dim objFolder As Object Dim objFile As Object FolderPath=ThisWorkbook.Path Set objShell=CreateObject("Shell.Application") Set objFolder=objShell.Namespace(ThisWorkbook.Path) For i=5 To Range("C1")End(xlDown).Row ObjFile.Name=FolderPath&Cells(i,1).value&".pdf" If Dir objFile.Name<>""Then objFolder.ParseName(objFile.Name).InvokeverbEx("print") Else End if Next i Set objFile=Nothing Set objFolder=Nothing Set objShell=Nothing MsgBox"印刷が完了しました" End Sub どこか文書変でしょうか？？ 添削してくださいませんか。 順番に印刷、、できるとすごく仕事がはかどるため、成功させたいです。 お力添え、何卒お願いいたします。
- ベストアンサー
- Excel（エクセル）
- サブフォルダからエクセルブックをとりだすマクロ
特定のフォルダからエクセルブックのみを抽出し別のフォルダに集める（コピーする）マクロを作りたいと思い、以下のように作成しました。 （AAAフォルダ⇒移動元、BBBフォルダ⇒移動先） ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。 AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。 ――――――――――― Sub sample1() Dim FSO As Object, fld As Variant, bk As Variant Const Fld1 As String = "C:\AAA" Const Fld2 As String = "C:\BBB\" Const tgt As String = "*.xlsx" Set FSO = CreateObject("Scripting.FileSystemObject") For Each fld In FSO.GetFolder(Fld1).SubFolders For Each bk In fld.Files If bk.Name Like tgt Then bk.Copy Fld2 End If Next bk Next fld End Sub
- 締切済み
- Excel（エクセル）
- マクロのことで再度質問です。
すいません、先ほど質問した者です。 http://okwave.jp/qa/q7357905.html 以下のマクロを試すと・・ Ａのセルに「ファイル名.txt」 Ｂのセルに「C:\Users\～￥フォルダ名」 となります。 この「.txt」と「C:\Users\～￥」は表示させたくありません。 自分でもいじってみたのですが、できませんでした。 表示させないようにするにはどうすればいいでしょうか？ 度々の質問で恐縮ですが、よろしくお願いします。 Sub Macro() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim FolderPath As String FolderPath = ThisWorkbook.Path Dim myFile As Object Dim i As Long i = 2 Dim myFolder As Object For Each myFolder In fso.GetFolder(FolderPath).SubFolders For Each myFile In fso.GetFolder(myFolder).Files Cells(i, 4).Value = myFolder Cells(i, 1).Value = myFile.Name Cells(i, 7).Value = fso.OpenTextFile(myFile.Path).ReadAll() i = i + 1 Next Next End Sub Private Sub CommandButton1_Click() End Sub
- ベストアンサー
- オフィス系ソフト
- 実家のパソコンが故障。自己診断をしてみるとエラーコード00410001が表示され、operating system not foundのメッセージが表示される。10年以上使用しているが、HDD交換だけでまだまだ使用可能か検討中。
- パソコン起動できずにエラーコード00410001とoperating system not foundのメッセージが表示される。10年以上使用しているが、HDD交換だけで継続して使用可能か確認したい。
- 実家のパソコンが起動しない。エラーコード00410001の表示とoperating system not foundのメッセージが出る。HDD交換だけでまだまだ使用可能か調査している。
お礼
早速ありがとうございました。私の理解の遥か先を行くことのようでした。解説ありがとうございました。