Excel VBA質問箱 IV

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

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


13688 / 76738 ←次へ | 前へ→

【68553】Re:指定フォルダ内のファイルの読み込み
回答  UO3  - 11/3/24(木) 10:00 -

引用なし
パスワード
   ▼ぴょんきち さん:

おはようございます。

ご参考までに、新規ブックのA列にブック名、B列に抽出ブックのA1の値、B列に抽出ブックのC1の値を
セットするコードを2つ。

Sample1Aは実際にブックを開いて参照します。
参照するシートは開いたブックの一番左にあるシートとしています。

Sample1Bはブックを開かずにセルの値を転記します。
ただし、シート名がわかっていることが前提。サンプルでは"Sheet1"としています。

Option Explicit

Sub Sample1A()
  Dim myPath As String
  Dim myFile As String
  Dim c As Range

  myPath = Get_Folder
  If myPath = "" Then Exit Sub

  Application.ScreenUpdating = False
 
  Workbooks.Add
  Cells.ClearContents
  Range("A1:C1").Value = Array("ファイル名", "A1", "C1") 'タイトル
  Set c = Range("A2") '編集開始位置

  myFile = Dir(myPath & "\*.xls") 'エクセルブックのみ抽出
  Do While myFile <> ""
    If myFile <> ThisWorkbook.Name Then '念のため
      c.Value = myFile
      Workbooks.Open myPath & "\" & myFile
      c.Offset(, 1).Value = Worksheets(1).Range("A1").Value
      c.Offset(, 2).Value = Worksheets(1).Range("C1").Value
      ActiveWorkbook.Close savechanges:=False
      Set c = c.Offset(1)
    End If
    myFile = Dir()
  Loop
 
  Columns("A:C").AutoFit

  Set c = Nothing
  Application.ScreenUpdating = True

End Sub

Sub Sample1B()
  Dim myPath As String
  Dim myFile As String
  Dim c As Range
  Dim refShn As String
  Dim linkStr As String
  
  myPath = Get_Folder
  If myPath = "" Then Exit Sub

  Application.ScreenUpdating = False
  
  refShn = "Sheet1" '参照するシート名。適宜変更。
  
  Workbooks.Add
  Cells.ClearContents
  Range("A1:C1").Value = Array("ファイル名", "A1", "C1") 'タイトル
  Set c = Range("A2") '編集開始位置

  myFile = Dir(myPath & "\*.xls") 'エクセルブックのみ抽出
  Do While myFile <> ""
    If myFile <> ThisWorkbook.Name Then '念のため
      c.Value = myFile
      linkStr = "='" & myPath & "\[" & myFile & "]" & refShn & "'!"
      c.Offset(, 1).Value = linkStr & "A1"
      c.Offset(, 2).Value = linkStr & "C1"
      c.Offset(, 1).Resize(, 2).Value = c.Offset(, 1).Resize(, 2).Value
      Set c = c.Offset(1)
    End If
    myFile = Dir()
  Loop
 
  Columns("A:C").AutoFit

  Set c = Nothing
  Application.ScreenUpdating = True

End Sub

Private Function Get_Folder() As String
Dim ffff As Object
Dim WSH As Object

  Set WSH = CreateObject("Shell.Application")
  Set ffff = WSH.BrowseForFolder(&H0, "フォルダを選択してください", &H1 + &H10)
  If ffff Is Nothing Then
    Get_Folder = ""
  Else
    Get_Folder = ffff.Items.Item.Path
  End If
 
  Set ffff = Nothing
  Set WSH = Nothing
 
End Function

0 hits

【68545】指定フォルダ内のファイルの読み込み ぴょんきち 11/3/22(火) 16:51 質問
【68546】Re:指定フォルダ内のファイルの読み込み UO3 11/3/22(火) 17:53 回答
【68547】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/3/22(火) 20:23 お礼
【68548】Re:指定フォルダ内のファイルの読み込み UO3 11/3/23(水) 11:33 回答
【68549】Re:指定フォルダ内のファイルの読み込み UO3 11/3/23(水) 11:57 回答
【68550】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/3/23(水) 14:44 質問
【68551】Re:指定フォルダ内のファイルの読み込み UO3 11/3/23(水) 17:01 回答
【68552】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/3/23(水) 20:12 お礼
【68553】Re:指定フォルダ内のファイルの読み込み UO3 11/3/24(木) 10:00 回答
【68597】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/3/28(月) 19:50 お礼
【68609】Re:指定フォルダ内のファイルの読み込み UO3 11/3/29(火) 10:11 回答
【68682】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/4/6(水) 16:05 お礼
【68686】Re:指定フォルダ内のファイルの読み込み UO3 11/4/6(水) 18:00 回答
【68723】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/4/10(日) 17:17 お礼
【68688】Re:指定フォルダ内のファイルの読み込み kanabun 11/4/7(木) 0:26 発言
【68691】Re:指定フォルダ内のファイルの読み込み UO3 11/4/7(木) 6:33 発言
【68692】Re:指定フォルダ内のファイルの読み込み kanabun 11/4/7(木) 9:14 発言
【68724】Re:指定フォルダ内のファイルの読み込み ぴょんきち 11/4/10(日) 17:23 お礼

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