VBAで他のエクセルファイルデータを読み込む方法
- VBAを使用して、複数のエクセルファイルのデータを集計ファイルに取り込む方法を教えてください。
- 現在、数字のみのファイル名の取り込みはできているが、数字とアルファベットの組み合わせのファイル名に対してデータを取り込む方法がわかりません。
- 試行錯誤とインターネットでの検索を行っても解決策が見つからず、困っています。どなたか教えていただけないでしょうか？
- ベストアンサー
ＶＢＡ 他のエクセルファイルデータを読み込む
エクセルのＶＢＡに関する質問です。 かじった程度の知識でがんばってはみたのですが、以下のことがどうしてもできません。 集計ファイルと、それぞれが入力するファイルがいくつか（具体的には１Ａ.xls、１Ｂ.xls、２Ａ.xls、２Ｂ.xlsといった数字とアルファベットの組み合わせ）あります。 入力ファイルに書かれているデータを集計ファイルに取り込もうと考えています。 入力ファイル名が（１.xls，２.xls・・・）の様に数字だけの取り込みはできました。 m = Val(UserForm2.TextBox1.Text) For i = 1 To m On Error GoTo myError Workbooks.Open Filename:="C:" & i & ".xls", UpdateLinks:=0 Range("f65536").End(xlUp).Activate Workbooks(i & ".xls").Activate Sheets("入力ファイル").Select Range("A3:X52").Select Application.CutCopyMode = False Selection.Copy Workbooks("集計ファイル.xls").Activate Sheets("DB").Activate Range("a65536").End(xlUp).Activate Selection.Offset(1).Select ActiveSheet.Paste Range("a65536").End(xlUp).Select Workbooks(i & ".xls").Close SaveChanges:=False myError: Next i Application.DisplayAlerts = True こんな感じです。 これを、数字だけでなく数字＋アルファベット.xlsのファイル名にしてデータを取り込むにはどうすればいいのでしょうか？色々と試行錯誤をしたり、ネットで調べたりしたのですが、詰んでしまいました。 どなたかお助け下さい。
- kokoa_3
- お礼率76% (48/63)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
まあ、色々な方法がありますが、集計するファイルの特定の セルに、ファイル名を書いておくのが簡単ではないかと思います。 例えば、セルA1からセルA5までに読み込むファイル名を書いて あったとして・・・ですね。 SUB TEST() FOR I=1 TO 5 F_NAME=Range("A"&I).Value Windows(F_NAME).Activate Cells.Select Selection.Copy Windows("集計ファイル.xls").Activate Sheets("Sheet"&I).Activate Cells.Select ActiveSheet.Paste NEXT I END SUB こんな感じで行けるるんじゃないかと。 入力データはシートごと一括コピーしちゃった方が多分楽です。
関連するQ&A
- ＥＸＣＥＬ ＶＢＡ セルからファイル名を読み込む
EXCEL ＶＢＡについての質問です 同じ処理を名前の違う複数のファイルで行いたいと思っています そこで、セルＡ２へファイル名の『○○.xls』○○部分だけをそれぞれのファイルに書き込んでおき、マクロは共通にしてファイル名をそれぞれのファイルから読み込んで実行したいと思っています。 良い方法を教えてください。 Workbooks("200809.csv").Activate Sheets("200809").Select Range("C3:C33").Copy Windows("○○.xls").Activate'←ここをファイルにあわせて変更できる形にしたい Sheets("報告書").Select Range("G5:G35").Select ActiveSheet.Paste Windows("200809.csv").Activate Range("K3:K33").Copy Windows("○○.xls").Activate’←ここ Sheets("報告書").Select Range("I5:I35").Select ActiveSheet.Paste Workbooks("200809.csv").Close SaveChanges:=False よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- ＶＢＡでブックの集計の仕方を教えてください。
Ｈ22.12月度と言う名前のフォルダーにＡ店～Ｅ店と集計と言う名前のブックがあります。 集計のブックでＡ店～Ｅ店の集計をしてくるマクロを組んでいますが上手く作動しません。 集計のブックには、セルの書式設定をしていますので、Ａ店～Ｅ店の売上一覧のシートから 値だけをコピーして集計したいのですが、罫線やパターン、数式までコピーしてきたり、 最後のＥ店だけ２重にコピーしてきたりと変な動作をします。 初心者で本やネットで調べながら作ったので、どこの記述がおかしくて、そうなるのかがさっぱりわかりません。 どなたか教えていただけませんでしょうか。よろしくお願いします。 Sub 集計() Workbooks.Open Filename:="C:\Documents and Settings\デスクトップ\H22.12月度\Ａ店.xls" Sheets("売上一覧").Select Range("E5:Q24").Select Selection.Copy Application.WindowState = xlMinimized Windows("集計.xls").Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False If Range("E5").Value <> "" Then Range("E65536").Select Selection.End(xlUp).Select Selection.Offset(1, 0).Select End If ActiveSheet.Paste Windows("Ａ店.xls").Activate Range("E5").Select Application.CutCopyMode = False ActiveWindow.Close ・ ・ ・（Ｂ・Ｃ・Ｄ店も同じ記述) ・ ・ Workbooks.Open Filename:="C:\Documents and Settings\デスクトップ\H22.12月度\Ｅ店.xls" Sheets("売上一覧").Select Range("E5:Q24").Select Selection.Copy Application.WindowState = xlMinimized Windows("集計.xls").Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False If Range("E5").Value <> "" Then Range("E65536").Select Selection.End(xlUp).Select Selection.Offset(1, 0).Select End If ActiveSheet.Paste Windows("Ｅ店.xls").Activate Range("E5").Select Application.CutCopyMode = False ActiveWindow.Close Windows("集計.xls").Activate Application.WindowState = xlMaximized Range("E5").Select End Sub
- ベストアンサー
- Visual Basic
- 別ブックからのデータ取り込み
下記の(1)(2)のマクロを(3)のコマンドボタンで実行させています。 (1)(2)を使用せずに(3)のコマンドボタンにまとめて記載したいのですが上手く出来ません。 また、(1)の"A:\あ.CSV"部分ですが、使用PCによってドライブが異なる場合があるります。セルC2に入力したドライブ名を反映させることはできないでしょうか？ よろしくお願いします。 (1) Sub I() Workbooks.Open Filename:="A:\あ.xls" lngR = Range("B65536").End(xlUp).Row Range("B2:B" & lngR).Select Selection.Copy Windows("か.xls").Activate Range("B3").Select ActiveSheet.Paste lngR = Range("B65536").End(xlUp).Row Range("B2:F" & lngR).Select With Selection.Font .Size = 8 End With End Sub (2) Sub II() Windows("あ.xls").Activate lngR = Range("E65536").End(xlUp).Row Range("E2:E" & lngR).Select Selection.Copy Windows("か.xls").Activate Range("G3").Select ActiveSheet.Paste lngR = Range("G65536").End(xlUp).Row Range("G2:G" & lngR).Select Selection.Style = "Comma [0]" With Selection.Font .Size = 9 End With Windows("あ.xls").Activate ActiveWindow.Close End Sub (3) Private Sub 取込_Click() Application.ScreenUpdating = False Protect UserInterfaceOnly:=True Application.Run "I" Application.Run "II" Selection.Locked = False Applicaion.ScreenUpdating = True End Sub
- 締切済み
- オフィス系ソフト
- 【Excel VBA】 多くのファイルからのコピー貼り付け連続処理
【やりたいこと】 アンケートを取った500個のxlsファイル（ファイル名は"001.xls"～"500.xls"まで、単純に規則的に数字が増えていく）があります。500個のファイルの中身（アンケートのフォーマット）は全て同じで、回答者の「答え」は"アンケート"というシートの"P6:S6"と"A70:AX70"という範囲に数列になって入っています。 この500個のファイルに対して、 （１）シートにはPassword付きの保護がかけてあるので、アンケート回答ファイルを開いたら保護を解除する （２）"アンケート"というシートの、ある範囲（回答部分の"P6:S6"と"A70:AX70"）をコピーし、集計用の別ファイルへ貼り付けていく（×500人分） （３）集計用の別ファイルに貼り付けるときは、1人目の"P6:S6"範囲の貼り付け先は"D4"、"A70:AX70"の範囲の貼り付け先は"I4"で、2人目はそれぞれ"D5"と"I5"、3人目は"D6"と"I6"、・・・とずらしていきます。（コピー元のセルは同じで、コピー先のセルがずれていきます） （４）コピー貼り付けが終わったアンケート回答は、上書き保存をせずに終了する（再び保護がかかった状態に戻して終了する） という操作を行うマクロを組みたいのです。 【つまづいている現状・・・】 とりあえず1人目の分だけ記録したマクロは以下の通りです。力技でやろうとすれば、"001.xls"を001～500まで、"D4"と"I4"を4～503まで、ずっと書き変えていけばいいんだと思いますが・・・。500人分を簡単にスッキリとまとめることはできませんでしょうか？ 何卒よろしくお願い致します。 -------------------------------------------------------------- Workbooks.Open Filename:="D:\AAA\001.xls" Sheets("アンケート").Select ActiveSheet.Unprotect Password:="1234" Range("P6:S6").Select Selection.Copy Windows("集計用ファイル.xls").Activate Range("D4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("001.xls").Activate ActiveWindow.SmallScroll Down:=8 Range("A70:AX70").Select Application.CutCopyMode = False Selection.Copy Windows("集計用ファイル.xls").Activate Range("I4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("001.xls").Activate Application.DisplayAlerts = False ActiveWindow.Close --------------------------------------------------------------
- ベストアンサー
- オフィス系ソフト
- エクセルＶＢＡ、他のファイルからのコピー
ＢＢＡ初心者です aaa.xlsのマクロで aaa.xls にbbb.csvのデータを貼り付けたいのですが Sub () Windows("bbb.csv").Activate…ここのbbbってところをセル参照にしたいのです ActiveCell.Range("A1:A10").Select Selection.Copy Windows("aaa.xls").Activate ActiveSheet.Paste End Sub １つ上のセルにbbbと入力されていればbbb.csvのデータを １つ上のセルにcccと入力されていればccc.csvのデータを 貼り付けれるようなマクロはどう書けばいいのでしょうか よろしくお願いします
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでのファイル転送
任意のアドレスに添付ファイルを付けて送信完了までのコードを教えてほしいです。 Workbooks("***.xls").Sheets("***").Activate Range("D8").Select /上記セルにメールアドレスを設定してます。/ Selection.Hyperlinks(1).Follow _ NewWindow:=False, AddHistory:=True 送り先は設定されるけど添付ファイルの付け方が判らない。 Workbooks("***.xls").Activate Application.Dialogs(xlDialogSendMail).Show 添付ファイルは付けれるけど送り先の設定が判らない。
- ベストアンサー
- Visual Basic
- このコードの修正を、何卒よろしくお願い致します。
EXEL 2002 です。 下記コードの修正を、何卒よろしくお願い致します。 ------ Sub コピー() Dim i As Integer For i = 1 To 2 Workbooks("コピー元.xls").Activate Worksheets(i).Range("A1", Range("C65536").End(xlUp).Offset(0, 168)).Copy _ Destination:=Workbooks("コピー先.xls").Worksheets(Workbooks("コピー先.xls").Sheets(1).Range("A1")) Next i End Sub
- ベストアンサー
- オフィス系ソフト
- オートフィルタをし選択・貼付をマクロにしたいのですが、対象データ表示される行が毎回違うのでうまくいきません。
いつもお世話になっております。 どなたかご教示いただければ助かります。 ファイル(1)のデータの中からA行が830となっているものを、ファイル(2)のページ1の一番下の行に付け足し 同じようにファイル(1)からA行が1000となっているものを、ファイル(2)のページ2の一番下に付け足す という作業をマクロでしたいのですが、毎回830と1000がセルAの何行目に表示されるのかが異なっており、オートフィルタをかけた状態でマクロにするとマクロ作成時にたまたま表示されていた行数が指定されているので、別の日に違う行数をコピーしてしまい私が作成したマクロではうまくいきません。 どう変更すれば宜しいでしょうか？ どうぞ宜しくお願い致します。 Workbooks.Open Filename:="mm.xls" ←上記文でファイル(1) Sheets(DM).Select Rows("1:1").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="<>*850*", Operator:=xlAnd, _ Criteria2:="<>*1000*" Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.EntireRow.Delete ActiveSheet.Rows("1:1").Select Selection.AutoFilter Windows("xx.xls").Activate ←ファイル(2) Sheets("ll").Select ←ページ1 ActiveSheet.Range("A1").Select Selection.End(xlDown).Select ActiveCell.Offset(1, 0).Activate Windows("mm.xls").Activate Rows("1:1").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="1000" Rows("3:3").Select Selection.Copy Windows("xx.xls").Activate ActiveSheet.Paste Application.CutCopyMode = False Windows("xx.xls").Activate Sheets("pp").Select ←ページ2 ActiveSheet.Range("A1").Select Selection.End(xlDown).Select ActiveCell.Offset(1, 0).Activate Windows("mm.xls").Activate Rows("1:1").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="850" Rows("2:2").Select Selection.Copy Windows("xx.xls").Activate ActiveSheet.Paste Application.CutCopyMode = False ActiveWorkbook.Save Windows("mm.xls").Activate ActiveWindow.Close End Sub
- ベストアンサー
- オフィス系ソフト
- VBAでの行削除について
教えてください。 現在、VBAを使用して、CSVファイルの編集をしたいと考えています。 フォルダ内に数個のCSVファイルがあり、それらにすべて同じ処理（行削除など）をしたいのです。 下記のようなプログラムです。 Sub getting() Dim myPath As String Dim myFName As String Dim FCnt As Integer Dim A(500) As String MsgBox CurDir() Workbooks("自動処理.xls").Activate myPath = ActiveWorkbook.Path MsgBox myPath ChDir myPath FCut = 0 myFName = Dir("*.csv") If myFName <> "" Then FCut = FCut + 1 A(FCut) = myFName Do myFName = Dir() If myFName <> "" Then FCut = FCut + 1 A(FCut) = myFName MsgBox A(FCut) Else Exit Do End If Loop End If MsgBox "「" & myPath & "」には、" & FCut & "個のファイルがあります。" Dim i As Integer Dim seet As String Dim ws As Object Dim FullPath As String For i = 1 To 1 seet = Left(A(1), 6) FullPath = myPath & "\" & A(i) 'Workbooks.Open(FullPath).Activate Open FullPath For Append As #1 Print #1, Rows("1:1").Select Selection.Delete Shift:=xlUp Rows("2:2").Select Selection.Delete Shift:=xlUp Range("A1").Select Print #1, Range("A1").Value = "" Print #1, Range("A1").Value = "COMP_NAME" Print #1, Range("B1").Select Print #1, ActiveCell.Value; "PC_OS" Print #1, Range("C1").Select Print #1, ActiveCell.Value = "OS_SUB_VERS" Print #1, Range("D1").Select Print #1, ActiveCell.Value = "IP_ADDR" Print #1, Range("E1").Select Print #1, ActiveCell.Value = "LOCATION " Close #1 ' Workbooks(A(i)).Save ' Workbooks(A(i)).Close savechanges:=False Next i End Sub 教えていただきたいのは、どうにかworkbook.openを使わず、ファイルを編集できるところまでいったのですが、ファイルを開かずに行を削除することができません。 ＞Print #1, Rows("1:1").Select ＞Selection.Delete Shift:=xlUp ＞Rows("2:2").Select ＞Selection.Delete Shift:=xlUp ファイルを開かずに行削除をできるものなのでしょうか。 ご存知の方がいれば教えてください。 よろしくお願いいたします。
- 締切済み
- その他（プログラミング・開発）
- マクロを使ったコピペがうまく動作しない。
あるデータを転記用のブック（月毎にシートが分かれています。シートの内容は同一）に貼り付ける処理を行うため、下記のようなマクロを組んだのですが、何故か貼りつきません。処理終了時には、転記元ブック（シート）で最終処理の範囲（５番目のB287）を選択しています。一体何がいけないのでしょうか？ データはA1からPまでで毎月可変しています。 また、転記用ブックが12枚あるため、月を指定してから貼り付けたいのですが、どのようにすればよいでしょうか？（下記は直接シ－トを指定しました） Sub test() Dim 最終行 As Integer '-------------------------------------------- 開始 Windows("21-12.xls").Activate 最終行 = Range("p65536").End(xlUp).Row Sheets("1").Range("A1:p" & 最終行).Select Selection.Copy Windows("転記.xls").Activate Sheets(12月).Select Range("B1").PasteSpecial Paste:=xlPasteValues '-------------------------------------------- 1 Windows("21-12.xls").Activate 最終行 = Range("p65536").End(xlUp).Row Sheets("2").Range("A1:p" & 最終行).Select Selection.Copy Windows("転記.xls").Activate Sheets(12月).Select Range("B83").PasteSpecial Paste:=xlPasteValues '-------------------------------------------- 2 Windows("21-12.xls").Activate 最終行 = Range("p65536").End(xlUp).Row Sheets("3").Range("A1:p" & 最終行).Select Selection.Copy Windows("転記.xls").Activate Sheets(12月).Select Range("B157").PasteSpecial Paste:=xlPasteValues '-------------------------------------------- 3 Windows("21-12.xls").Activate 最終行 = Range("p65536").End(xlUp).Row Sheets("4").Range("A1:p" & 最終行).Select Selection.Copy Windows("転記.xls").Activate Sheets(12月).Select Range("B227").PasteSpecial Paste:=xlPasteValues '-------------------------------------------- 4 Windows("21-12.xls").Activate 最終行 = Range("p65536").End(xlUp).Row Sheets("5").Range("A1:p" & 最終行).Select Selection.Copy Windows("転記.xls").Activate Sheets(12月).Select Range("B287").PasteSpecial Paste:=xlPasteValues --------------------------------------------- 5 End Sub
- 締切済み
- オフィス系ソフト
お礼
できました！ありがとうございました。