Excel VBA質問箱 IV

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

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


72686 / 76732 ←次へ | 前へ→

【8528】Re:他のEXCELファイルの、ある範囲をパタ...
回答  INA  - 03/10/22(水) 16:50 -

引用なし
パスワード
   時間がないので、手持ちのをすこし編集しました。
参考になれば幸いです。

Sub sample()
Dim ファイル As String
Dim 一覧 As String
Dim Result As Long
Dim myObj As Object
Dim myDir As String

'Application.ScreenUpdating = False

Set myObj = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0)

If myObj Is Nothing Then Exit Sub
  myDir = myObj.Items.Item.Path & "\"
 

'##################################
' 同フォルダ内のExcelファイル検出
'##################################

  ファイル = Dir(myDir & "*.xls")
  
  Do While ファイル <> ""
    If ファイル = ThisWorkbook.Name Then ファイル = ""
    一覧 = 一覧 & Chr(13) & ファイル
    ファイル = Dir()
  Loop

 Result = MsgBox("以下のファイルが見つかりました。実行しますか?" & Chr(13) & 一覧, 4, "ファイル確認")
 If Result = 7 Then
  Exit Sub
 End If


'########################
'   データのコピー
'########################
ファイル = Dir(myDir & "*.xls")
 
 Do While ファイル <> ""
  If ファイル <> ThisWorkbook.Name Then
    'ファイルを開く
    Workbooks.Open Filename:=myDir & ファイル
   
    MsgBox ファイル & "を開いています。ここでコピー処理します。"
    
    'ファイルを閉じる
    ActiveWorkbook.Close False
  End If
  ファイル = Dir()
 Loop

'Application.ScreenUpdating = True

End Sub

1 hits

【8512】他のEXCELファイルの、ある範囲をパターン化しその結果を新規EXCELファイル... テーブル 03/10/22(水) 12:04 質問
【8513】Re:他のEXCELファイルの、ある範囲をパター... INA 03/10/22(水) 13:18 回答
【8514】Re:他のEXCELファイルの、ある範囲をパター... テーブル 03/10/22(水) 13:50 質問
【8515】Re:他のEXCELファイルの、ある範囲をパター... テーブル 03/10/22(水) 14:06 質問
【8519】Re:他のEXCELファイルの、ある範囲をパター... INA 03/10/22(水) 15:37 回答
【8521】Re:他のEXCELファイルの、ある範囲をパタ... INA 03/10/22(水) 15:48 回答
【8525】Re:他のEXCELファイルの、ある範囲をパタ... テーブル 03/10/22(水) 16:33 お礼
【8528】Re:他のEXCELファイルの、ある範囲をパタ... INA 03/10/22(水) 16:50 回答
【8529】Re:他のEXCELファイルの、ある範囲をパタ... テーブル 03/10/22(水) 17:00 お礼

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