ついに夏本番!さぁ、家族でキャンプに行くぞ! >>

すみません、知恵をお貸しください。

VBA初心者です。
一つの同じフォルダ内にあるエクセルの同じ形式の複数ファイル(*.xls)から、データを抽出し(例.A2:k2)一つのファイルを作成したいのですが、どうにか一行目だけを抽出することができました。

しかし、データ抽出をしたい複数ファイルの中には(A2:k2)だけではなく、複数行に渡りデータが入っているもの(A3:k3まで、やA5:k5までなど)があり、それら全てを抽出したいのです。

何らかの条件付けの上でループをさせればいいのかな?とも考えたのですが、うまくいきません。

どうかご教授お願いします。

このQ&Aに関連する最新のQ&A

A 回答 (1件)

    • good
    • 0
この回答へのお礼

ありがとうございます☆
すごく参考になりました^^

お礼日時:2009/05/19 14:26

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q複数のエクセルファイルからデータ抽出とまとめる方法について。

500のエクセルファイルがあり、それぞれのエクセルデータのA2からF2までのデータのをまとめた一覧表(1行目は、1枚目のエクセルファイルのA2-F2、2行目は2枚目のエクセルファイルの・・・、という感じでです)のを、新しいエクセルファイルもしくはテキストなどにでも手早く作れる方法をご存知の方、ご教授ください。コピペでやっていますが嫌になってしまいました。。マクロも触っては見たのですが、2枚目のエクセルファイルを2行目に、3枚目のエクセルファイルを3行目になどの方法の解決は思いつかず、挫折しました。よろしくお願いいたします

Aベストアンサー

対象のフォルダをcドライブの「sample」とした場合で回答します。
新規エクセルブックのシート名タブを右クリックし「コードの表示」
右側のエディタエリアに下記コードを貼り付け、実行して下さい。
G列にファイル名が入るようになっています。不要であれば
Cells(rIdx, 7).Value = fName
を削除して下さい。


Sub getA_F()
Const myPath As String = "c:\sample\"
Dim rIdx As Long
Dim fName As String
fName = Dir(myPath & "*.xls")
Do Until fName = ""
Workbooks.Open Filename:=myPath & fName
rIdx = rIdx + 1
Me.Range(Cells(rIdx, 1), Cells(rIdx, 6)).Value = ActiveSheet.Range("A2:F2").Value
Cells(rIdx, 7).Value = fName
Windows(fName).Close
fName = Dir
Loop
End Sub

対象のフォルダをcドライブの「sample」とした場合で回答します。
新規エクセルブックのシート名タブを右クリックし「コードの表示」
右側のエディタエリアに下記コードを貼り付け、実行して下さい。
G列にファイル名が入るようになっています。不要であれば
Cells(rIdx, 7).Value = fName
を削除して下さい。


Sub getA_F()
Const myPath As String = "c:\sample\"
Dim rIdx As Long
Dim fName As String
fName = Dir(myPath & "*.xls")
Do Until fName = ""
Workbooks.Open ...続きを読む

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む

Q複数のエクセルファイルとシートからデータ抽出したい

すみませんが教えてください!
複数のエクセルファイルがあり、それぞれに複数のシートがあります。
(ファイルによってシート数は異なります)
そのすべてのファイル/シートから、C列の最後の行のデータを抽出し、集計ファイルに書き出したいのです。
書き出しのフォーマットは3セル使用して、ファイル名、シート名、データとしたいです。
すみませんが、よろしくお願いいたします。

Aベストアンサー

集計用のブックを用意する
Sheet1のA1、B1、C1セルに「ファイル名」「シート名」「データ」と記入しておく
集計ブックを、あなたの「複数のエクセルファイル」が放り込んであるフォルダに一緒に保存しておく


改めて集計ブックを開く
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 myfile = dir(mypath & "*.xls*")
 application.screenupdating = false
 do until myfile = ""
  if myfile <> thisworkbook.name then
   workbooks.open mypath & myfile
   for each w in workbooks(myfile).worksheets
   with thisworkbook.worksheets("Sheet1").range("A65536").end(xlup).offset(1)
    .value = myfile
    .offset(0, 1) = w.name
    .offset(0, 2).value = w.cells(w.rows.count, "C").end(xlup).value
   end with
   next
   workbooks(myfile).close false
  end if
  myfile = dir()
 loop
 application.screenupdating = true
end sub

ファイルメニューから終了してエクセルに戻る
ALT+F8を押してマクロを実行する。

集計用のブックを用意する
Sheet1のA1、B1、C1セルに「ファイル名」「シート名」「データ」と記入しておく
集計ブックを、あなたの「複数のエクセルファイル」が放り込んであるフォルダに一緒に保存しておく


改めて集計ブックを開く
ALT+F11を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
 dim myPath as string
 dim myFile as string
 dim w as worksheet

 mypath = thisworkbook.path & "\"
 myfile = dir(mypath & "...続きを読む

Q複数の同じフォーマットのファイルを新しいブックで一つのシートにまとめる方法

仕事で、各部署から送られてきた、同じフォーマットのファイル(シート1にのみデータ有)が50個近くあります。
それを新しいブックで一つのシートにまとめなくてはいけません。
地道にコピペするのは時間がかかるのでマクロで処理を行いたいと思います。
マクロでの処理方法ご存知の方、処理方法の載っているサイトをご存知の方、もしくはマクロより簡単な方法がありましたら教えてください。

あと、逆に一つのシートをいくつかのファイルに振り分けていく方法もご存知でしたら教えて下さい。
よろしくお願いします。

Aベストアンサー

すみません。質問を勘違いしていました。
>新しいブックで一つのシートにまとめなくてはいけません
でしたね。
Sub Sample1()
Dim buf As String, i As Long
Dim j
buf = Dir(Sheets("Sheet1").Range("A1").Value & "\*.xls")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet1").Range("A1").Value & "\" & buf
Sheets("Sheet1").Range("A1:J1000").Copy
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False
buf = Dir()
Loop
End Sub
で試してみてください。使い方などは
http://oshiete1.goo.ne.jp/qa4225063.html
を参照してみてください。同じ質問があったので気がつきました。

すみません。質問を勘違いしていました。
>新しいブックで一つのシートにまとめなくてはいけません
でしたね。
Sub Sample1()
Dim buf As String, i As Long
Dim j
buf = Dir(Sheets("Sheet1").Range("A1").Value & "\*.xls")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet1").Range("A1").Value & "\" & buf
Sheets("Sheet1").Range("A1:J1000").Copy
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCop...続きを読む

QEXCELで複数のファイルから抽出

Excelのことで困っています。
何かいい方法があれば教えてください。

同じフォームのエクセルファイルが約1000ファイルあり、それぞれのファイルの例えば3~5行目だけを抽出し、別のの新しいファイルにどんどん貼り付けて3~5行目だけを集めたファイルを作りたいのですが、ファイルの数が多いので、全ファイルを開いてコピペする以外にマクロか何かを使って自動で抽出できるような方法がないかと考えております。
1000個のファイル名は今はばらばらですが、必要であれば0001.xls~1000.xlsなどに変更してもよいです。

どうぞよろしくお願いします。

Aベストアンサー

抽出先のブックを同じフォルダに作成し、Alt+F11でVBAの画面を開き、左側のツリーからブック名を選択し、右クリックから「挿入」>「標準モジュール」を選択して、右の画面に以下のマクロをコピーして貼り付けてください。

Sub ファイルから抽出()
 Dim FName As String
 Dim Folder As String
 Dim WB As Workbook
 Dim i As Integer, j As Integer
 Application.ScreenUpdating = False
 Folder = ThisWorkbook.Path & "\"
 i = 1: j = 1
 Worksheets(1).Cells.ClearContents
 FName = Dir(Folder & "*.xls")
 Do While FName <> ""
  If FName <> ThisWorkbook.Name Then
   Workbooks.Open (Folder & FName)
   Workbooks(Workbooks.Count).Worksheets(1).Rows("3:5").Copy _
   ThisWorkbook.Worksheets(1).Cells(i, 1)
   Workbooks(Workbooks.Count).Close
   Application.StatusBar = j & "ファイル処理済み"
   i = i + 3: j = j + 1
  End If
  FName = Dir()
 Loop
 Application.StatusBar = ""
 Application.ScreenUpdating = True
 MsgBox ("完了しました")
End Sub

Alt+F11でExcelの画面に戻ってAlt+F8からマクロを実行してみてください。各ファイルの3行目~5行目がコピーされます。

高速化のために処理中は描画を止めているので、全ての処理が終わった後に画面は表示されます。1000個もファイルがあるとかなり時間がかかると思いますが、何個のファイルを処理したかは左下に表示するようにしているので、ある程度目安になると思います。

あと、フォルダ内のブックを開いてはコピーして閉じ、ということを繰り返しているので、実行中はタスクバーがちらちらしますが、気にしないでください。

抽出先のブックを同じフォルダに作成し、Alt+F11でVBAの画面を開き、左側のツリーからブック名を選択し、右クリックから「挿入」>「標準モジュール」を選択して、右の画面に以下のマクロをコピーして貼り付けてください。

Sub ファイルから抽出()
 Dim FName As String
 Dim Folder As String
 Dim WB As Workbook
 Dim i As Integer, j As Integer
 Application.ScreenUpdating = False
 Folder = ThisWorkbook.Path & "\"
 i = 1: j = 1
 Worksheets(1).Cells.ClearContents
 FName = Dir...続きを読む

QEXCEL VBAマクロ作成で、他のEXCELからデータを取り込みたい

メインプログラム(EXCEL VBA)より、
他のフォルダーにあるEXCELの項目の内容を取り込みたいです。
たとえば他のフォルダーのEXCELのRange("A2:A3").ValueをメインプログラムのRange("C2:C3").Valueにセットしたい時です。

・コマンドボタン押したら、どこのEXCELから取り込むかのポップアップ(?)は、表示はできてます。
・作業者が選んだパスとブックもMsgBoxで表示できてるので、もらう相手の場所も取得できてます。

・となると次はOPEN,INPUTですか?
テキストデータの取り込みですと、Inputでそのバッファを定義してるのですが、なんか違うような。。。

よろしくお願いします!

Aベストアンサー

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Cells(2, 2).Value ' 相手シートの B2 の値を自分自身の A1 に書き込む

readBook.Close False ' 相手ブックを閉じる
Set readSheet = Nothing
Set readBook = Nothing

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Ce...続きを読む

QExcelの複数ファイルの内容を一つのファイルに集計する方法について教

Excelの複数ファイルの内容を一つのファイルに集計する方法について教えてください。
各支店からの報告を集計したいのですが、同一フォームのファイル(約100ファイル)で報告されるデータを一つのファイルに集計したいと思っています。
A支店ファイルのsheet1、B支店ファイルのsheet1、・・・・を、合計ファイルのsheet1に集約したいのです。(フォームは同じで、内容は数値のみです。)
いい方法がある方、お教えください。

Aベストアンサー

フォルダー内の全エクセルファイルのデータを1シートにまとめるVBAのコードはWeb検索すれば、種々みつかります。下記はコードの若干の解説もあって良いと思います。
http://hpcgi1.nifty.com/kenzo30/b_cbbs/cbbs.cgi?mode=al2&namber=39812&no=0&P=R&KLOG=266
問題は、「同一フォーム」の内容ですね。
データ中に各支店名が含まれていなければ、抽出時に付与しないと訳が分からなくなるし、
変に凝った様式だと単純にコピーするだけではうまくいかないし。

Qフォルダ内の全てのBookに同じ処理を繰り返す

フォルダ内にエクセルファイルが約3,000個あります。
この全てのBookに同じ処理をしたいのですが、マクロで繰り返す方法がわからないので教えて下さい。
処理をする内容は簡単なもので、マクロで作りました。

・ 各Bookには1つのシートしか存在せず、シート名は重要ではないので全て「Sheet1」になっています。
・ 各Bookのデータの配置や表形式は同じです。
・ レコードの行数がBookによって異なります。

処理の内容をマクロで作るところまではできましたが、知識がないためタイムアウトです。

ご教示宜しくお願い致します。

Aベストアンサー

だいたいこんな流れで。

sub macro1()
 dim myPath as string
 dim myFile as string

 mypath = "C:\test\"

’指定フォルダのブックを順繰り拾う
 myfile = dir(mypath & "*.xls*")
 do until myfile = ""

 ’ブックを開いて処理を行い保存して閉じる
  workbooks.open mypath & myfile
  activesheet.range("A1") = "DONE"
  activeworkbook.close true

  myfile = dir()
 loop
end sub


必要に応じて
・画面の表示を抑制する
・再計算を手動にする
といった手管を追加して高速化を図ります。

Q複数エクセルから特定シートの特定行だけを別シートに抽出するマクロ

エクセルブックが160ほどあります。
それらは全て同じ作りで、シートが2つづつ存在しています。
その2シート目(シート名”集約”シート)にある特定のセル(A2からT2)だけを
別のエクセルに集めて一覧にしたいです。

色々とやってみてネット検索もしてみたのですが、うまくいかないので
どなたか教えていただけませんでしょうか。

Aベストアンサー

こんな感じで、どうでしょう。
MyPathで指定したフォルダ内の .xlsx ファイルを対象に一覧化します。
一覧は、A列にファイル名、B列以降に各ブック中の”集約”シートのA2~T2が表示されます。
ただし、”集約”シートが無い場合は、ちょっとおかしな動作をします。おかしな動作については、お楽しみ!!(元のファイルが壊れることは無いので、安心して実行してみて下さい)

Sub sample()
Dim MyPath As String
Dim MyFile As String
Dim I As Long
MyPath = "C:\教えてGoo\"
MyFile = "*.xlsx"
MyFile = Dir(MyPath & MyFile)
Do While MyFile <> ""
I = I + 1
Cells(I, "A") = MyFile
Range(Cells(I, "B"), Cells(I, "U")).Formula = "='" & MyPath & "[" & MyFile & "]Sheet1'!A2"
MyFile = Dir
Loop
End Sub

こんな感じで、どうでしょう。
MyPathで指定したフォルダ内の .xlsx ファイルを対象に一覧化します。
一覧は、A列にファイル名、B列以降に各ブック中の”集約”シートのA2~T2が表示されます。
ただし、”集約”シートが無い場合は、ちょっとおかしな動作をします。おかしな動作については、お楽しみ!!(元のファイルが壊れることは無いので、安心して実行してみて下さい)

Sub sample()
Dim MyPath As String
Dim MyFile As String
Dim I As Long
MyPath = "C:\教えてGoo\"
MyFile = "*.xlsx"...続きを読む

Qエクセルで、条件に一致した行を別のセルに抜き出す方法

エクセルで、指定した条件に一致するセルを含む行をすべて抜き出す方法が知りたいです。

たとえば、

<A列> <B列> <C列>
7/1 りんご 100円
7/2 ぶどう 200円
7/2 すいか 300円
7/3 みかん 100円

このような表があって、100円を含む行をそのままの形で、
別のセル(同じシート内)に抜き出したいのですが。

7/1 りんご 100円
7/3 みかん 100円

抽出するだけならオートフィルターでもできますが、
抽出結果を自動的に、別の場所に、常に表示させておきたいのです。

初歩的な質問だと思いますが、検索しても分からなかったので、よろしくお願いします。

Aベストアンサー

同じ質問が結構よく出てますが、そんなに初歩的でもありません
別シートのA1セルに「100円」と入力し、そのシートの任意のセルに以下の式を貼り付けて下さい。後は、下方向、右方向にコピー。
日付のセル書式は「日付」形式に再設定してください

=IF(COUNTIF(Sheet1!$C:$C,$A$1)>=ROW(A1),INDEX(Sheet1!A:A,LARGE(INDEX((Sheet1!$C$1:$C$500=$A$1)*ROW(Sheet1!$C$1:$C$500),),COUNTIF(Sheet1!$C:$C,$A$1)-ROW(A1)+1)),"")

データ範囲は500行までとしていますが、必要に応じて変更して下さい


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報