人力検索はてな
ﾓﾊﾞｲﾙ版を表示しています｡PC版はこちら
i-mobile
出来ればｴｸｾﾙだけで完結させたいのですが､例えば100個のｴｸｾﾙﾌｧｲﾙの A1ｾﾙに入っている値(情報)を一気に抜き出し101目(べつに何個目でもいいですが)のｴｸｾﾙに抜き出した値(情報)を表示させたいです｡ ｱｸｾｽでもいいですが､一番簡単な方法で抜き出す方法を教えてください｡
●質問者: miyako333
●ｶﾃｺﾞﾘ:ｺﾝﾋﾟｭｰﾀ
○ 状態 :終了
└ 回答数 : 1/1件
▽最新の回答へ
▽1 ● degucho
●100ﾎﾟｲﾝﾄ ﾍﾞｽﾄｱﾝｻｰ

VBAﾏｸﾛを記述したﾌﾞｯｸと同じﾌｫﾙﾀﾞ内にあるﾌﾞｯｸのA1ｾﾙの内容を
新規ｼｰﾄに転記するﾏｸﾛを作成してみました


Public Sub ReadAllA1()

  'このﾌｫﾙﾀﾞ内のﾌｧｲﾙを処理(今回はﾏｸﾛ配置ﾌﾞｯｸと同じ場所とする)
 Dim baseDir As String
 baseDir = ThisWorkbook.Path + "\"
 
  'このﾊﾟﾀｰﾝでxlsxもﾋｯﾄする
 Dim pattern As String
 pattern = baseDir + "*.xls"
 
 Dim fileName As String
 fileName = Dir(pattern)
 
 Dim row As Integer
 row = 1
 
  '結果貼り付け用に新規ｼｰﾄ作成
 Dim mySheet As Worksheet
 Set mySheet = Worksheets.Add
 
 Do While (fileName <> "")
  '自分自身以外のﾌｧｲﾙの場合
 If (fileName <> ThisWorkbook.Name) Then
 
  'ﾌﾞｯｸを開いてA1を取得
 Dim wkb As Workbook
 Set wkb = Workbooks.Open(baseDir + fileName)
 Dim wks As Worksheet
 Set wks = wkb.Worksheets(1)
 Dim value As String
 value = wks.Range("A1").value
 
  '結果ｼｰﾄのA列にﾌｧｲﾙ名､B列にA1ｾﾙの値を転記
 mySheet.Cells(row, 1) = fileName
 mySheet.Cells(row, 2) = value
 row = row + 1
 
 Debug.Print value
 Set wks = Nothing
 wkb.Close
 Set wkb = Nothing
 
 
 End If
 fileName = Dir()
 Loop

 mySheet.Cells.EntireColumn.AutoFit
 Set mySheet = Nothing
 

End Sub
miyako333さんのｺﾒﾝﾄ
ありがとうございます｡ 追加ですがこれに 例えば B1,C1,D1ｾﾙと対象を増やす場合は "A1" のところをどう変えればいいでしょうか｡またほかに書き換えるところはありますか？
deguchoさんのｺﾒﾝﾄ
改造すればいかようにもなると思いますが 範囲が広い場合､Range("A1:D1")などとして転記したほうがいいかもしれません｡ http://officetanaka.net/excel/vba/cell/cell09.htm あと､Debug.Printは削除忘れのﾃﾞﾊﾞｯｸﾞｺｰﾄﾞなので不要です｡
miyako333さんのｺﾒﾝﾄ
現実的には､例えば A1､C3､F4､ G1､H1,I1 の値を 抜き出して 今回教えてもらったみたいに A列に ﾌｧｲﾙ名 B列に A1 C列にC3､D列にF4､ E列にG1､F列にH1､G列にI1ｾﾙの値を つらつらと表示させたいです｡ これだとどう書けばいいでしょうか｡ ﾏｸﾛが苦手ですいません｡ ぜひ教えて助けてください｡ よろしくお願いします｡
deguchoさんのｺﾒﾝﾄ
直してみました｡ 苦手なのにVBAはOKですとか 質問に具体例を書かないのはﾀﾞﾒですよ >|VB| Public Sub ReadAll() 'このﾌｫﾙﾀﾞ内のﾌｧｲﾙを処理(今回はﾏｸﾛ配置ﾌﾞｯｸと同じ場所とする) Dim baseDir As String baseDir = ThisWorkbook.Path + "\" 'このﾊﾟﾀｰﾝでxlsxもﾋｯﾄする Dim pattern As String pattern = baseDir + "*.xls" Dim fileName As String fileName = Dir(pattern) Dim row As Integer row = 1 '結果貼り付け用に新規ｼｰﾄ作成 Dim mySheet As Worksheet Set mySheet = Worksheets.Add Do While (fileName <> "") '自分自身以外のﾌｧｲﾙの場合 If (fileName <> ThisWorkbook.Name) Then 'ﾌﾞｯｸを開いてA1を取得 Dim wkb As Workbook Set wkb = Workbooks.Open(baseDir + fileName) Dim wks As Worksheet Set wks = wkb.Worksheets(1) Dim valueA1 As String Dim valueC3 As String Dim valueF4 As String Dim valueG1 As String Dim valueH1 As String Dim valueI1 As String valueA1 = wks.Range("A1").value valueC3 = wks.Range("C3").value valueF4 = wks.Range("F4").value valueG1 = wks.Range("G1").value valueH1 = wks.Range("H1").value valueI1 = wks.Range("I1").value '結果ｼｰﾄのA列にﾌｧｲﾙ名､B列以降に取得した値を転記 mySheet.Cells(row, 1) = fileName mySheet.Cells(row, 2) = valueA1 mySheet.Cells(row, 3) = valueC3 mySheet.Cells(row, 4) = valueF4 mySheet.Cells(row, 5) = valueG1 mySheet.Cells(row, 6) = valueH1 mySheet.Cells(row, 7) = valueI1 row = row + 1 Set wks = Nothing wkb.Close Set wkb = Nothing End If fileName = Dir() Loop mySheet.Cells.EntireColumn.AutoFit Set mySheet = Nothing End Sub ||<
関連質問
●質問をもっと探す●

0.人力検索はてなﾄｯﾌﾟ
8.このﾍﾟｰｼﾞを友達に紹介
9.このﾍﾟｰｼﾞの先頭へ
□対応機種一覧
□お問い合わせ
□ﾍﾙﾌﾟ/お知らせ
□ﾛｸﾞｲﾝ
□無料ﾕｰｻﾞｰ登録
□はてなﾄｯﾌﾟ