Excel VBA質問箱 IV

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

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


68910 / 76734 ←次へ | 前へ→

【12348】Re:Excel VBAで、同一フォルダに格納され...
回答  IROC  - 04/3/31(水) 14:40 -

引用なし
パスワード
   動作未確認です。
別フォルダに、コピーのファイルを何個か用意して、試して下さい。
(いきなり、大事なデータで試さないで下さい。)

マクロブックの開かれているシートに、抽出します。
問題点などありましたら、連絡下さい。

Sub Sample()
Dim myObj As Object
Dim myDir As String
Dim myFileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Long
    
  'フォルダ選択ダイアログの表示
  Set myObj = CreateObject("Shell.Application"). _
  BrowseForFolder(0, "フォルダを選択してください", 0)
  If myObj Is Nothing Then Exit Sub
 
  myDir = myObj.Items.Item.Path
  If Right(myDir, 1) <> "\" Then myDir = myDir & "\"


'フォルダ内のExcelファイル検出
  myFileName = Dir(myDir & "*.xls")
  
With ThisWorkbook.ActiveSheet
    .Cells.ClearContents 'クリア
    .Range("A1").Value = "ブック名"
    .Range("B1").Value = "見積もり工数時間"
    .Range("C1").Value = "TOTAL時間"
    .Range("D1").Value = "超過時間"
    
  Do While myFileName <> ""
    If myFileName = ThisWorkbook.Name Then myFileName = ""
    
      'ブック開く
      Set wb = Workbooks.Open(myDir & myFileName)
      Set ws = wb.Worksheets("合計")
                  
      'データを入力する最下行を求める
      r = .Range("A65536").End(xlUp).Offset(1).Row
      
      .Cells(r, 1).Value = wb.Name 'ブック名
      .Cells(r, 2).Value = ws.Range("D1").Value '見積もり工数時間
      .Cells(r, 3).Value = ws.Range("C15").Value 'TOTAL時間
      .Cells(r, 4).Value = ws.Range("C17").Value '超過時間
      
      'ブック閉じる
      wb.Close
    
    myFileName = Dir()
  Loop

End With
End Sub

1 hits

【12345】Excel VBAで、同一フォルダに格納された... ひろκ 04/3/31(水) 13:53 質問
【12346】Re:Excel VBAで、同一フォルダに格納された... IROC 04/3/31(水) 14:06 回答
【12347】Re:Excel VBAで、同一フォルダに格納された... ひろκ 04/3/31(水) 14:18 質問
【12348】Re:Excel VBAで、同一フォルダに格納され... IROC 04/3/31(水) 14:40 回答
【12349】Re:同一フォルダの全ファイルを集計して表... ひろκ 04/3/31(水) 15:16 質問
【12365】Re:同一フォルダの全ファイルを集計して表... IROC 04/4/1(木) 9:39 回答
【12366】Re:同一フォルダの全ファイルを集計して... ひろκ 04/4/1(木) 10:28 お礼
【12367】Re:同一フォルダの全ファイルを集計して... IROC 04/4/1(木) 11:27 回答

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