Excel VBA質問箱 IV

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

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


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

【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 発言[未読]

【37029】この処理についてですが・・・・
質問  よしの  - 06/4/20(木) 0:39 -

引用なし
パスワード
   'Do セルが空セルだ
'If セル結合されてる
   '○ひとつしたのセルへ
'ElseIf セル結合されていない
   'Selection.Offset(1, 0).Select
'End If
'ElseIf セルが空セルでない
'IF 検索してセルと同じ名前のフォルダがある
  'If 検索してセルと同じ名前のファイルがある
    '○ファイル元からコピーして所定の場所に保存
  'ElseIf 検索してセルと同じ名前のファイルがない
    '○セルにいろをつける
    '○次のセルに移動
  'End if
'ElseIF 検索してセルと同じ名前のフォルダがない
  '○フォルダの作成
  '○ファイル元からコピーして所定の場所に保存
'End If

この一連の処理を、選択したセルの下に
何もない(間に何個か空セルを入れて、値があったら駄目)
セルまで繰り返したいのですが、どうしても分かりません・・・

【37050】Re:この処理についてですが・・・・
発言  ハチ  - 06/4/20(木) 10:49 -

引用なし
パスワード
   ▼よしの さん:
>'Do セルが空セルだ
> 'If セル結合されてる
>   '○ひとつしたのセルへ
> 'ElseIf セル結合されていない
>   'Selection.Offset(1, 0).Select
> 'End If
>'ElseIf セルが空セルでない
> 'IF 検索してセルと同じ名前のフォルダがある
>  'If 検索してセルと同じ名前のファイルがある
>    '○ファイル元からコピーして所定の場所に保存
>  'ElseIf 検索してセルと同じ名前のファイルがない
>    '○セルにいろをつける
>    '○次のセルに移動
>  'End if
> 'ElseIF 検索してセルと同じ名前のフォルダがない
>  '○フォルダの作成
>  '○ファイル元からコピーして所定の場所に保存
> 'End If
>
>この一連の処理を、選択したセルの下に
>何もない(間に何個か空セルを入れて、値があったら駄目)
>セルまで繰り返したいのですが、どうしても分かりません・・・

もう少し条件を整理したほうがコメントが付き易いと思いますよ。
1.結合セルと空白セルは無視する。 ってことですか?
2.ファイルとフォルダの関係がよくわかりません。
3."検索して"は、別ファイル名(フォルダ名)を検索するのですか?
4.ファイル元から「何を」コピーしてどこが「所定の場所」なのでしょうか?

【37056】Re:この処理についてですが・・・・
発言  Jaka  - 06/4/20(木) 13:16 -

引用なし
パスワード
   全然解らないですけど...。
組み方が解らないって事だとして、大体こんな感じ。
まんまの説明でいいのか解らなかったんで、所々コードを入れました。

i = 1 '行カウンタに1
'セルA列i行目のセルが空白になるまで繰返し
Do Until Cells(i,1).Value = ""
  'セルA列i行目が結合セルでなかったら
  If Not Cells(i,1).MergeArea then
   'セルA列i行目に書いてあるフォルダ(フルパス)があれば
   If Dir(Cells(i,1).value,vbDirectory) <> "" then
     'セル???に書いてあるファイルがあれば
     IF Dir(Cells(i,1).value & "\" & Cells(?,??).value) <> "" then
      ○ファイル元からコピーして所定の場所に保存
     Else
      ○セルにいろをつける
     End If  
   Else 'フォルダがなければ、フォルダ作成
     MkDir (Cells(i,1).value)
     ○ファイル元からコピーして所定の場所に保存
   End if
  Endif
  i = i + 1 '行カウンタに+1
Loop

【37078】Re:この処理についてですが・・・・
発言  よしの  - 06/4/20(木) 21:37 -

引用なし
パスワード
   ▼ハチ さん:
>▼よしの さん:
>>'Do セルが空セルだ
>> 'If セル結合されてる
>>   '○ひとつしたのセルへ
>> 'ElseIf セル結合されていない
>>   'Selection.Offset(1, 0).Select
>> 'End If
>>'ElseIf セルが空セルでない
>> 'IF 検索してセルと同じ名前のフォルダがある
>>  'If 検索してセルと同じ名前のファイルがある
>>    '○ファイル元からコピーして所定の場所に保存
>>  'ElseIf 検索してセルと同じ名前のファイルがない
>>    '○セルにいろをつける
>>    '○次のセルに移動
>>  'End if
>> 'ElseIF 検索してセルと同じ名前のフォルダがない
>>  '○フォルダの作成
>>  '○ファイル元からコピーして所定の場所に保存
>> 'End If
>>
>>この一連の処理を、選択したセルの下に
>>何もない(間に何個か空セルを入れて、値があったら駄目)
>>セルまで繰り返したいのですが、どうしても分かりません・・・
>
>もう少し条件を整理したほうがコメントが付き易いと思いますよ。
>1.結合セルと空白セルは無視する。 ってことですか?

はい!そうです!

>2.ファイルとフォルダの関係がよくわかりません。
あるセルの値を参照して、それと同じ名前のファイルを
別のフォルダから探して、新たに作ったフォルダに名前を変えてコピー
したいです!

>3."検索して"は、別ファイル名(フォルダ名)を検索するのですか?
デスクトップにフォルダがすでにあるかないか。
それと、ある元のフォルダに、コピーするための
ファイルが存在するかどうかです!

>4.ファイル元から「何を」コピーしてどこが「所定の場所」なのでしょうか?

すみません・・・・全然知識がないですが、
明日までには仕上げないといけませんT T
よろしくおねがいたします。

【37096】Re:この処理についてですが・・・・
質問  ハチ  - 06/4/21(金) 9:33 -

引用なし
パスワード
   よしのさん

Excelのサンプルデータを書いてください。
(A列フォルダ名とか、どの列が結合されてるとかも)
フォルダ名もファイル名も混在しているってことですか?

>>もう少し条件を整理したほうがコメントが付き易いと思いますよ。
>>1.結合セルと空白セルは無視する。 ってことですか?
>
>はい!そうです!
>
>>2.ファイルとフォルダの関係がよくわかりません。
>あるセルの値を参照して、それと同じ名前のファイルを
>別のフォルダから探して、新たに作ったフォルダに名前を変えてコピー
>したいです!

別のフォルダから探して とありますが、全ファイルシステムから探すのですか?
特定のフォルダ?

>>3."検索して"は、別ファイル名(フォルダ名)を検索するのですか?
>デスクトップにフォルダがすでにあるかないか。
>それと、ある元のフォルダに、コピーするための
>ファイルが存在するかどうかです!
>
>>4.ファイル元から「何を」コピーしてどこが「所定の場所」なのでしょうか?

ファイルを探してデスクトップにフォルダを作って中にコピーする
ってことなんでしょうか?

>すみません・・・・全然知識がないですが、
>明日までには仕上げないといけませんT T
>よろしくおねがいたします。

【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

【37113】Re:この処理についてですが・・・・
質問  よしの  - 06/4/22(土) 2:01 -

引用なし
パスワード
   はちさんへ

大変ご親切にありがとうございました!

といっても、また条件が増えてしまいましたが;;

でも、ホントにありがとうございました。

最後に教えて頂きたいの事があります。
出来るだけ詳しく書かせていただきます。
****************************************
1.最初にマクロを実行したときに
どのファイルでも選べれるように、
マイドキュメントのウインドを開く。

2.選んだエクセルファイルを開くと
そのブックの中の”部材明細”と書かれたシートをマクロで探し出して
アクティブにする(何枚かある場合は、番号の若いシートから)

3.最後に、何枚かコピーしたファイルの一覧を
”コピー元の名前とコピーして変更した名前”を
対応させたテキストファイルを、作りたい。
****************************************

この三つが教えて頂きたい事です。
もし、良かったらお願いいたします!
不躾がましくすみません。

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