エクセルで複数のブックの一部を抽出する
- エクセルで複数のブックの一部をBOOK1に1行ずつコピーする方法について質問しています。
- 参考にしたサイトを元に、特定の列のデータを別のブックにコピーしたいとのことです。
- VBAのコードを使用して、指定されたデータをBOOK1にコピーする方法が説明されています。
- ベストアンサー
エクセルで複数のブックの一部を抽出する
エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか? merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、 課名D16 商品名B20:B39 枚数H20:H39 金額I20:I39 の部分をbook1に1件1行としてコピーしたいのですができますでしょうか? もとのブックの行数は決まっています。 どうか力を貸してください。よろしくお願いします。 Sub test02() Dim MyFile As String, MyPath As String '変数宣言 Dim x As Long, y As Long Dim wb As Workbook, tb As Workbook Dim ka As String Dim sh1, sh2 Set tb = ThisWorkbook MyPath = tb.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル Application.ScreenUpdating = False '画面更新停止 Application.Calculation = xlCalculationManual '自動計算停止 Do While MyFile <> "" 'エクセルファイルがなくなるまで If MyFile <> tb.Name Then '自分以外のファイルを対象 Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く With ActiveSheet ka = .Range("D16").Value '課名取得 x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 sh1 = .Range("B20:B" & x).Value '商品名取得 sh2 = .Range("H20:I" & x).Value '数量&金額取得 End With With tb.Sheets("Sheet1") y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 y = IIf(.Range("B" & y) = "", y, y + 1) If x >= 20 Then '納品書B20以下にデータがあれば Set myRng = .Range("A" & y).Resize(x - 19, 1) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = sh1 '商品名転記 myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量&金額転記 End If End With wb.Close (False) '選択したファイルを閉じる End If MyFile = Dir() '次のファイルを検索 Loop '繰り返し Application.Calculation = xlCalculationAutomatic '自動計算停止解除 Application.ScreenUpdating = True '画面更新停止解除 Set tb = Nothing Set wb = Nothing Set myRng = Nothing End Sub
- root38_001
- お礼率21% (3/14)
- その他MS Office製品
- 回答数1
- ありがとう数1
- みんなの回答 (1)
- 専門家の回答
質問者が選んだベストアンサー
質問の内容がよく分かりませんが >・・・これを参考にして作っているのですが、 変更部分は? >元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか? >・・・の部分をbook1に1件1行としてコピーしたいのですができますでしょうか? 例を挙げて説明した方がわかりやすいかも 以上よく分ってませんが この様なことがしたいのかな? : : Set myRng = .Range("A" & y).Resize(x - 19, 1) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = sh1 '商品名転記 myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量&金額転記 : : ↓ ↓ : : Set myRng = .Range("A" & y) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = WorksheetFunction.Transpose(sh1) '商品名転記 myRng.End(xlToRight).Offset(, 1).Value = WorksheetFunction.Transpose(sh2) '数量&金額転記 : : 参考になりますか
関連するQ&A
- 複数のエクセルデータ上特定位置の値を一つのセルに2
前回の質問「複数のエクセルデータ上特定位置の値を一つのセルに」に対し、ベストアンサーを教えていただきました。その質問とご回答のポイントは次の通りです。 質問: 大量の同じフォーマットのエクセルファイル(Book1,Book2...)があり、それぞれのBookファイルの「NO.」シートのD6セルには番号が入っています。それぞれファイルでSheet1の特定のセル(例えばB4セル)の値を「データ」ファイルのSeet1にまとめたいです。「データ」ファイルのA列には「NO.」が入力されているので、Bookファイルの値はそれぞれ対応する番号の右側3番目のセルに移したいです。 ご回答: sub macro1() dim myPath as string dim myFile as string dim myNo as variant dim myRng as range on error resume next application.screenupdating = false mypath = "c:\test\" ’book1,2,3…の保存場所を指定する事 myfile = dir(mypath & "*.xlsx") ’拡張子を正しく指定すること do until myfile = "" workbooks.open mypath & myfile myno = workbooks(myfile).worksheets("No.").range("D6").value set myrng = thisworkbook.worksheets("Sheet1").range("A:A").find(what:=myno, lookin:=xlvalues, lookat:=xlwhole) myrng.offset(0, 3).value = workbooks(myfile).worksheets("Sheet1").range("B4").value workbooks(myfile).close savechanges:=false myfile = dir() loop application.screenupdating = true end sub 現在Excel2007を使っており、Bookファイルが全部(.xlsx)の状態では問題なく使えましたが、ファイルが97-2003の(.xls)バージョンになると、マクロを実行したときに次のメッセージが出ます。「データ.xlsmは既に開いています。2重に開くと、これまでの変更内容は破棄されます。データ.xlsmを開きますか?」 もちろんご回答の中の「myfile = dir(mypath & "*.xlsx") ’拡張子を正しく指定すること」は("*.xls")に変更されている状態です。 何が問題なのか全く分からず、困っています。どなたか教えていただけないでしょうか? よろしくお願い致します。
- ベストアンサー
- Excel(エクセル)
- エクセルのCSV形式の複数ブックを一括でインポートしたい
あるフォルダ内にある「複数ブック(CSV形式)」をエクセルに一括でインポートしたいのです。フォルダ内にある複数のエクセルブックの名前はばらばですが、形式だけが全て同じです。 Book1 A B C 1 1 1 Book2 A B C 2 2 2 Book3 A B C 3 3 3 ↑ 2つブックがあって最終的には・・・・ Book5 A B C 1 1 1 2 2 2 3 3 3 ↑ こうしたいです。複数ブックの一行目以下のデータ全てをひとつのものにまとめたいのです。(全ての複数のCSVブックは一行目は同じです。2行目以降を追加するみたいな感じです。) いろいろと調べて作ってみたのですが、「デバック」??で黄色くなって全く上手く行きません。 ご存知であれば是非教えてください。 ・~・・~・・~・・~・・~・・~・・~・・~・・~・・~・ Sub フォルダ指定連結() Dim myShell As Object Dim myFS As Object, myFile As Object Dim myName As String, myPath As String Dim myLine As String, newStr As String Set myShell = CreateObject("Wscript.Shell") myPath = myShell.Specialfolders("Desktop") & "\aaa\" Set myShell = Nothing Set myFS = CreateObject("Scripting.FileSystemObject") myName = Dir(myPath & "\*.csv\") Do While myName <> "" Set myFile = myFS.OpenTextFile(myPath & "\" & myName, 1) myFile.ReadLine '1行目スキップ Do Until myFile.AtEndOfStream myLine = myFile.ReadLine newStr = newStr & myLine & vbCrLf Loop myFile.Close myName = Dir() Loop Set myFile = myFS.CreateTextFile("C:\test.csv\", True) myFile.Write newStr myFile.Close Set myFS = Nothing Set myFile = Nothing End Sub ・~・・~・・~・・~・・~・・~・・~・・~・・~・・~・ これが教えていただいたり、自分で修正を加えたりしたぶんですが・・・。 環境はウィンドウズXPで2002です。
- ベストアンサー
- Windows XP
- VBAでブック名の拡張子を除去してシートにコピー
VBA初心者でコード作成で困っております。 下記の通りコードを組みましたが、シート名をブック名に変更して 保存したいのですが、このコードですと拡張子までついてしまいます。 拡張子を除去するためにはどうすればよいでしょうか? アドバイス宜しくお願い致します。 Sub test() 'シート名の変更 Dim MyPath As String Dim MyFile As String Dim Wb As Workbook MyPath = "C:\TEST\" MyFile = Dir(MyPath & "*.xlsx") Do While MyFile <> "" Set Wb = Workbooks.Open(MyPath & MyFile) ActiveSheet.Name = ActiveWorkbook.Name Application.DisplayAlerts = False Wb.Save Application.DisplayAlerts = True Wb.Close (False) MyFile = Dir() Loop End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで別ブックの条件検索
VBA初心者です。エクセルは2007です。 『データのあるブック(Book1,Book2,Book3)』と、『検索条件シート+出力先シートをもつブック』の4つのブックがあります。 検索条件シートで、L22でブック、P22でシートを指定してN22に入力した数に対応するデータをVlookupで出力先シートのセルに抽出されるようにしたいのですが、※の部分で「エラー438 オブジェクトは、このプロパティまたはメソッドをサポートしていません」とでて実行できません。 データのあるブックは同じ形式でシートには表があります。 数 a b c d 1 A B C D 2 ○ × △ ■ 3 Z Y X W ・ ・ 検索条件がL22=3,P22=2,N22=2だとすると、Book3の2枚目のシートを検索し、 出力先シートのD1=○,J6=×,L23=△,J69=■となるようにしたいです。 本やインターネットで調べましたがわかりませんでした。 解決方法を教えていただきたいです。お願いします。 Sub 検索() Dim a, b, c, d As Range Dim 番号, ブック, シート As Integer With Workbooks("検索.xlsm").Sheets("検索条件") 数 = .Range("N22").Value ブック = .Range("L22").Value シート = .Range("P22").Value End With Dim wb As Workbook Dim sh As Worksheet Dim set範囲 As Variant With Workbooks("検索条件.xlsm").Sheets("出力先") Set a = .Range("D1") Set b = .Range("J6") Set c = .Range("L23") Set d = .Range("J69") End With Select Case ブック Case 1 Set wb = Workbooks("Book1.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2) Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case 2 Set wb = Workbooks("Book2.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2) Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case 3 Set wb = Workbooks("Book3.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2) Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case Else MsgBox "nothing", vbExclamation, "nothing" End Select ※Set set範囲 = wb.sh.Range("A4:E42") ←エラー438 a = Application.WorksheetFunction.VLookup(数, set範囲, 2, False) b = Application.WorksheetFunction.VLookup(数, set範囲, 3, False) c = Application.WorksheetFunction.VLookup(数, set範囲, 4, False) d = Application.WorksheetFunction.VLookup(数, set範囲, 5, False) End Sub
- ベストアンサー
- その他MS Office製品
- 複数ファイルのA1だけを抽出して別ファイルにしたい
すみませんが、教えてください。 特定のフォルダ内に入っているcsvのA1列目のみ抽出して別ファイルにしたく、検索したところ 同じように困っていた方がいたようで、参考にさせていただいたのですが、 以下を実行しても インデックスが有効範囲にありませんと出ます。 各csvファイルのシート名は 1000近くあるファイル全て違い、別々の名前(コード00-000とか)になっています。 (エクセルで開いたとき) お手数ですが、教えていただきたくお願いいたします。 参考にしたマクロです。 Sub macro1() Dim myPath As String Dim myFile As String myPath = "ファイルの場所\" myFile = Dir(myPath & "*.xls") Do Until myFile = "" Workbooks.Open myPath & myFile With Workbooks("集約.xls").Worksheets("Sheet1").Range("A65536").End(xlUp) .Offset(1, 0).Value = myFile .Offset(1, 1).Value = Workbooks(myFile).Worksheets("概要").Range("C3").Value End With Workbooks(myFile).Close savechanges:=False myFile = Dir() Loop End Sub 宜しくお願いいたします。
- 締切済み
- SE・インフラ・Webエンジニア
- フォルダ内の特定ブックだけを1つのブックにまとめる
以前こちらで質問させて頂きましたフォルダ内の特定ブックだけを1にのブックにまとめる方法で、大変助かっていましたがブック名が変更になり、教えて頂いたマクロでは実行できなくなったので自分なりに考えたのですがどうしてもできません。 質問時のブック名は「1_****」と「2_****」で 今回「1_****」だけが「1(3)_****」に変更になりました。 下記のマクロでmyfile = dir(mypath & "1_" & "*.xl*")→myfile = dir(mypath & "1(3)_" & "*.xl*")に変更するのはわかるのですが do until myfile = "" myfile2 = "2" & mid(myfile,2,99)をどう変更すれば良いかわかりません どなたかお助け頂けませんか? sub macro1() dim myPath as string dim myFile as string dim myFile2 as string mypath = "c:\test\" myfile = dir(mypath & "1_" & "*.xl*") do until myfile = "" myfile2 = "2" & mid(myfile,2,99) workbooks.open mypath & myfile workbooks.open mypath & myfile2 application.displayalerts = false workbooks(myfile).worksheets("2").delete application.displayalerts = true workbooks(myfile2).worksheets("2").move after:=workbooks(myfile).worksheets("1") workbooks(myfile).close true workbooks(myfile2).close false myfile = dir() loop end sub
- 締切済み
- オフィス系ソフト
- 複数のエクセルファイルとシートからデータ抽出したい
以前に http://soudan1.biglobe.ne.jp/qa8369459.html でやられている内容なのですが、私の場合はシートすべての[i4」のセル値を一覧でひっぱりたいです。 keithinさんご回答の 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 ↑をRange("i4").Value end with next workbooks(myfile).close false end if myfile = dir() loop application.screenupdating = true end sub にて実施しましたが、ファイル名・シート名は正確に抽出するものの 参照したい「i4」のデータが先頭のシートのi4だけを拾ってしまいます 1.xls、2.xls、3xlsがありそれぞれ名前がばらばらなシート「あ」、「い」、「う」の3つがある。2.xlsには「え」、「お」、「か」のしーとがあると仮定、マクロを実行すると、一覧のエクセルに 1、xls あ あのシートi4の値 1、xls い あのシートi4の値 1、xls う あのシートi4の値 2.xls え えのシートi4の値 2.xls お えのシートi4の値 2.xls か えのシートi4の値 子のようなか形で出力されます い のところには いのシートのi4が、う のところには うのシートのi4が、 抽出されるには構文をどう買えればよいのでしょうか
- ベストアンサー
- Visual Basic
- エクセルVBAでファイル作成
エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記() Dim myPth As String, fname As String Dim myRng As Range, myC As Range Dim i As Long, x As Long Dim wb(2) As Workbook Dim ws As Worksheet Dim t As Single t = Timer Set wb(0) = ThisWorkbook myPth = wb(0).Path With wb(0).Sheets("Key") Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData End With For Each myC In myRng Application.EnableEvents = False Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm") Set ws = wb(1).Sheets("List") With wb(0).Sheets("DATA") .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9") .ShowAllData End With With ws x = .Cells(Rows.Count, "A").End(xlUp).Row myC.Offset(, 2).Value = x '行数確認 .Range("A9").Value = 1 If x > 9 Then .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番 End If End With wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm" wb(1).Close (False) Application.EnableEvents = True i = i + 1 Next MsgBox i & "件を完了" _ & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel(エクセル)
- excel マクロ PDF化の際のエラーについて
エクセルブックを一括で名前をつけてpdfに変換するようなマクロを作ろうとして作ってみました。 基本は、マクロで印刷を一気に行う要領でpdfをアクティブプリンタに設定したのですが、見かけ上pdfファイルが作成されるものの、開くと破損していますとなってしまい、きちんとpdf化が出来ていないようです。 システムフォントを利用~のエラーは回避できたのですが、無理やりファイル名を指定しているせいでこのようになっているのでしょうか。 お手数ですがアドバイスをお願いします。 マクロの記録ではアクティブプリンタを指定して、プリントアウトというものしか記録されないので、プリントアウトのところが何か間違っているとは思うのですが・・・ 以下コードです。 Sub PrtPDF() Dim MyFile As String, MyPath As String Dim wb As Object Dim fn As String If vbNo = MsgBox("フォルダ内のブックの一括印刷を行いますか?", vbYesNo) Then GoTo CloseFile Dim bookname1 As String bookname1 = "Conv.xls" MyPath = ThisWorkbook.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のxlsファイル If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Do Until MyFile = "" '対象ファイルがなくなるまで Set wb = Workbooks.Open(MyPath & "\" & MyFile) '選択したファイルを開く fn = MyPath & "PDF\" & Range("J4").Value & ".pdf" 'アクティブシートを印刷する。 Application.ActivePrinter = "Adobe PDF on Ne07:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrtoFileName:=fn 'アクティブブックを閉じる。 ActiveWorkbook.Close MyFile = Dir '次のファイルを検索 If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Set wb = Nothing Loop '繰り返し GoTo ProcessEnd CloseFile: ActiveWorkbook.Close MsgBox "処理を中止しました。" Exit Sub ProcessEnd: MsgBox "処理が終了しました" End Sub
- 締切済み
- Visual Basic
- エクセルVBA抽出がうまく出来ません
エクセル2013VBA初心者です。 入力シートからDBシートへ、DBシートから印刷シートへのデータ転記と印刷、入力内容のクリアまでは出来るようになりました。 DBシートの検索を行い、記録内容を入力シートに転記する抽出を行いたいのですが、下記構文を書いたところで問題が発生しました。 If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then でとまります。メッセージは ‘Range’メソッドは失敗しました:‘Workshieet’オブジェクトというものです。 やろうとしていることは、入力シートに設けた“E12”と”G12”の二つの検索項目をキーにDBシートの行を特定し、この行の内容を入力シートに反映しようということです。 入力シートの検索項目“E12”、 ”G12”はそれぞれDBシートのA列、B列に格納されている項目で、年度と連番です。サンプルとして入力シート"C5"に抽出しようとしているDBシートD列は申請者名です。 恐れ入りますがよろしくご教示頂きたく、お願い申し上げます。 Sub DBシートから力情報を抽出する () Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim i As Long Dim j As Long Dim k As Long Set Sh1 = Worksheets("入力") Set Sh2 = Worksheets("DB") j = Sh1.Range("E12").Value k = Sh1.Range("G12").Value With Sh2 For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then Sh1.Range("C5").Value = Sh2.Range("D & i").Value End If Next End With End Sub
- ベストアンサー
- Excel(エクセル)
お礼
どうもありがとうございました。 shが10まであるのですが、最後は myRng.End(xlToRight).Offset(, 10).Value = WorksheetFunction.Transpose(sh10) ではなくそのまま myRng.Offset(, 10).Value = WorksheetFunction.Transpose(sh10) でうまくいきました。只、Bの列に空白があるとそのブックは読み込まれません。空白に-などを入れればいいのですが、もしお分かりでしたらお願いします。現在以下のようになっています。 ka = .Range("k2").Value '日付取得 x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 sh1 = .Range("B33:B38" & x).Value sh2 = .Range("C33:C38" & x).Value sh3 = .Range("D33:D38" & x).Value sh4 = .Range("E33:E38" & x).Value sh5 = .Range("F33:F38" & x).Value sh6 = .Range("G33:G38" & x).Value sh7 = .Range("H33:H38" & x).Value sh8 = .Range("I33:I38" & x).Value sh9 = .Range("J33:J38" & x).Value sh10 = .Range("K33:K38" & x).Value End With With tb.Sheets("Sheet1") y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 y = IIf(.Range("B" & y) = "", y, y + 1) If x >= 20 Then 'B20以下にデータがあれば Set myRng = .Range("A" & y) '.Resize(x - 19, 1) myRng.Value = ka myRng.Offset(, 1).Value = WorksheetFunction.Transpose(sh1) myRng.Offset(, 2).Value = WorksheetFunction.Transpose(sh2) myRng.Offset(, 3).Value = WorksheetFunction.Transpose(sh3) myRng.Offset(, 4).Value = WorksheetFunction.Transpose(sh4) myRng.Offset(, 5).Value = WorksheetFunction.Transpose(sh5) myRng.Offset(, 6).Value = WorksheetFunction.Transpose(sh6) myRng.Offset(, 7).Value = WorksheetFunction.Transpose(sh7) myRng.Offset(, 8).Value = WorksheetFunction.Transpose(sh8) myRng.Offset(, 9).Value = WorksheetFunction.Transpose(sh9) myRng.Offset(, 10).Value = WorksheetFunction.Transpose(sh10) 説明不足ですみませんでした。
補足
すみません自己解決?しました。Bに設定しているところをAに変えることで(Aは日付で空白はないので)すべてのデータが抽出されました。 根本的な解決ではないのかもしれませんが、、。 ありがとうございました。