Excel VBA質問箱 IV

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

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


44643 / 76732 ←次へ | 前へ→

【37104】Re:この処理についてですが・・・・
回答  ハチ  - 06/4/21(金) 15:03 -

引用なし
パスワード
   なんだか良くわかりませんでしたが、
A列:元ファイル名, B列:新フォルダ名, C列:新ファイル名 と
並んでいると仮定して作ってみました。ALoopを実行してください。

ものすごく無駄の多いマクロな気がします・・・

'○A列で結合セル、空白セル以外を実行する。
Sub ALoop()

Dim i As Integer

For i = 1 To Worksheets(1).UsedRange.Rows.Count + 1
  If Cells(i, 1).MergeCells = False Then
    If Cells(i, 1).Value <> "" Then
      Call FSearch(Cells(i, 1).Value, i)
    End If
  End If

Next i

End Sub

'○このファイル配下にファイルがあるか探す。
Sub FSearch(FName As String, i As Integer)

Dim MyPath As String
Dim c As Integer

MyPath = ThisWorkbook.Path

With Application.FileSearch
  .NewSearch
  .LookIn = MyPath
  .SearchSubFolders = True
  .Filename = FName
  .FileType = msoFileTypeAllFiles
  If .Execute() > 0 Then
    For c = 1 To .FoundFiles.Count
      If FName = Dir(.FoundFiles(c), vbNormal) Then
      Call DTSerach(.FoundFiles(c), i)
      Exit Sub
      End If
    Next c
  End If
  
  'ファイルがないのでA列に色を塗る
  Cells(i, 1).Interior.ColorIndex = 3
End With

End Sub

'○デスクトップにB列のフォルダがあるか調べる。
'フォルダがあれば、フォルダ内にコピー。なければフォルダを作ってコピー
Sub DTSerach(OldFile As String, i As Integer)
  Dim objFolder As Object
  Dim objSub As Object
  Dim WSH As Object
  Dim DTPath As String
  Dim MkPath As String
  

Set WSH = CreateObject("WScript.Shell")
DTPath = WSH.SpecialFolders("Desktop")

Set objFolder = CreateObject("Scripting.FileSystemObject").GetFolder(DTPath)
  For Each objSub In objFolder.Subfolders
    If Cells(i, 2).Value = objSub.Name Then
      FileCopy OldFile, objSub & "\" & Cells(i, 3).Value
      Exit Sub
    End If
  Next objSub

'フォルダがないので作成して中にコピー
  MkPath = DTPath & "\" & Cells(i, 2).Value
  MkDir (MkPath)
  
  FileCopy OldFile, MkPath & "\" & Cells(i, 3).Value

End Sub
4 hits

【37029】この処理についてですが・・・・ よしの 06/4/20(木) 0:39 質問
【37050】Re:この処理についてですが・・・・ ハチ 06/4/20(木) 10:49 発言
【37078】Re:この処理についてですが・・・・ よしの 06/4/20(木) 21:37 発言
【37096】Re:この処理についてですが・・・・ ハチ 06/4/21(金) 9:33 質問
【37104】Re:この処理についてですが・・・・ ハチ 06/4/21(金) 15:03 回答
【37113】Re:この処理についてですが・・・・ よしの 06/4/22(土) 2:01 質問
【37056】Re:この処理についてですが・・・・ Jaka 06/4/20(木) 13:16 発言

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