• 締切済み

【VBA】マクロについて質問です。

マクロ超初心者です。 取引先との面談の記録を残しているファイルがあり、その中の何個かの特定のセルを別のファイルに積み上げる形式でコピーしたいです。（全シート分）（シートの数はファイルによって違います） コピーしたい特定のセルをA１～A５までに貼り付けて、 次のシートはB１～B５と、項目ごとに下へ下へと貼り付けるようにしたいです。 取引先のファイルには複数シートがあり、フォーマット自体はすべて同じです。 現在以下マクロを組んでいます。 Sub 移行実験 Dim oldWB As Workbook, newWB As Workbook Dim I As Integer, s As string, xFile As String With Application.FileDialog(msoFileDialogOpen) .Title = "変換ファイル選択" If . Show = True Then xFile = .SelectedItems(1) Else Exit Sub End If End With Set oldWB = Workbooks. Open(xFile) Set newWB = Workbooks. Open(ThisWorkbook. Path & "¥新.xlsx 'ここに複数シートの内容を別ブック（新.xlsx）のひとつのシートにまとめるマクロを入れたいです。' newWB. SaveAs Filename:=ThisWorkbook.Path & "\" & _ oldWB.Worksheets(1) . Range("A1") . Value, FileFormat:=xlWorkbookNormal oldWB. Close False: newWB. Close False End Sub もっとこうした方がいいと思う所や、修正する箇所もあれば教えていただけると幸いです。 マクロ初心者のため、分かりやすく教えていだだけると有難いです。 どうぞよろしくお願いいたします。

みんなの回答

  • sora1515
  • ベストアンサー率58% (54/92)
回答No.1

ここはVBの質問をする所ですよ。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • Excelマクロのエラー

    お世話になります。 マクロは、超初心者で只今、本やネットで勉強中なのですが、本の通りに作成しましたが、 エラーが出てしまいます。 急いでおりまして、大変お手数ですがご教示お願いできますでしょうか？ Excel2007でマクロを作成中（実際に業務で使用する環境は2003です）。 2点あります。 (1)サブフォルダ内の全ブックを開く 　ファイルは開くのですが、下記のエラーが出てしまいます。 　C：￥...... "\web保存\"が見つかりません。ファイル名およびファイルの保存場所が 　正しいかどうかを確認してください。 (2)開いたファイルをhtm保存する。 　htm保存できるのですが、ファイル名が「●●●.xls.htm」 　となってしまい、元のファイル名の.xlsの拡張子が付いたままです。 　ファイル名を変えず、「●●●.htm」となるようにしたいです。 どうぞ宜しくお願い致します。 (1)サブフォルダ内の全ブックを開く Sub 全ブックを開く() Dim パス名 As String Dim ファイル名 As String パス名 = ThisWorkbook.Path & "\web保存\" ファイル名 = Dir(パス名 & "*.xls*") Do While ファイル名 <> " " Workbooks.Open パス名 & ファイル名 ファイル名 = Dir() Loop End Sub (2)開いたファイルをhtm保存する Sub htm保存() Dim wb As Workbook Dim wbname As String For Each wb In Workbooks wb.Activate If wb.Name <> ThisWorkbook.Name Then wb.SaveAs FileName:=ThisWorkbook.Path & "\" & wb.Name & ".htm", FileFormat:=xlHtml, CreateBackup:=False wb.Close savechanges:=False End If Next End Sub

  • 複数のブックの特定シートを1つのブックにまとめたい

    複数のブックの特定のシートを1つのブックにまとめたいのですが そのマクロは下記のように検索してでてきたのですが Sub test() Dim Fname As String Dim Wbm As Workbook Dim Wbs As Workbook Application.ScreenUpdating = False Set Wbs = ThisWorkbook Fname = Dir(ThisWorkbook.Path & "\*.xlsx*") Do While Fname <> "" If Fname <> ThisWorkbook.Name Then Workbooks.Open ThisWorkbook.Path & "\" & Fname Set Wbm = ActiveWorkbook Wbm.Worksheets("2016.03").Copy after:=Wbs.Worksheets(Wbs.Worksheets.Count) ActiveSheet.Name = Left(Fname, InStr(Fname, ".") - 1) Wbm.Close End If Fname = Dir() Loop Application.ScreenUpdating = True End Sub たとえば、特定のシートというのが毎回変わる場合今回は”2016.03"ですが 次回は”2016.04”という風に変わる時、どこかに入力したセルの値を元にシートを検索してくることなどは可能なのでしょうか？ よろしくお願い致します。

  • エクセルのVBAに関する質問です。

    エクセルのVBAに関する質問です。 「指定フォルダ（ここではXXXX）内の全てのエクセルファイルを開き、内容を転記していく」 というマクロについての質問です。 ネットを参照し、以下のマクロを見つけました。 -------------------------------------------------------------------------- Sub Macro1() Dim theName As String Dim theDir As String Dim theBook As Workbook Dim flg As Boolean flg = True Application.ScreenUpdating = False theDir = ThisWorkbook.Path & "\XXXX" theName = Dir(theDir & "\*.xls") Do While theName <> "" Set theBook = Workbooks.Open(theDir & "\" & theName) Call subA(theBook, flg) flg = False theBook.Close theName = Dir Loop End Sub Sub subA(theBook As Workbook, flg As Boolean) Dim thetbl As Range, LRow As Long Set thetbl = theBook.Sheets(1).Range("A1").CurrentRegion thetbl.Copy With ThisWorkbook.ActiveSheet LRow = .Range("A65536").End(xlUp).Row If LRow = 1 Then .Range("A" & LRow).PasteSpecial xlPasteValues Else .Range("A" & LRow + 1).PasteSpecial xlPasteValues End If End With Application.CutCopyMode = False End Sub -------------------------------------------------------------------------- 実際にはこのマクロは上手く動作していますが、１つ疑問があります。 「一度開いたファイルは開かない」というのはどの部分のおかげか、ということです。 当方初心者で、分かりづらい質問かもしれませんが、どうぞご教授お願いいたします。

  • Excel VBA: 自動でxlsファイルを開くマクロでメッセージが現れたとき自動でボタンを押す方法

    自動で同ディレクトリ内のxlsファイルを開くマクロを作っています。 開きたいファイルにリンクが張られてあると、「リンクを更新しますか？」という類のメッセージウィンドウが現れるのですが、マクロでこれを自動的に「Yes」「No」と答えるにはどうしたらよいのでしょうか。一応、下のマクロでファイルを開こうとするとこまではできてます。 　Sub update() Dim DataFile As Workbook Dim fn As String fn = "Link.xls" Set DataFile = Workbooks.Open(FileName:=ThisWorkbook.Path & "\" & fn) Set DataFile = Nothing End Sub

  • VBA　フォルダ内ファイルにマクロ一括処理

    フォルダ内ファイルのマクロを一括実行したいです。 フォルダ内ファイル全てに下記のマクロを登録 Sub 値貼り付け() 'シート4番目を選択 Sheets(4).Select 'シート名1文字目が「★」以外のシートを選択 For Each i In ThisWorkbook.Sheets If Not i.Name Like "★*" Then i.Select Replace:=False End If Next i '全セル選択 Cells.Select 'コピー Selection.Copy '値貼り付け Selection.PasteSpecial Paste:=xlPasteValues Cells(1, 1).Select Sheets(1).Select '「.xlsx」で保存 Application.DisplayAlerts = False Dim fso, f Set fso = CreateObject("Scripting.FileSystemObject") With ActiveWorkbook f = fso.GetBaseName(.Name) .SaveAs .Path & "\" & f & "保存.xlsx", FileFormat:=xlWorkbookDefault .Close End With Set fso = Nothing End Sub 一括でマクロを実行する用のファイルに下記マクロを登録 Sub 一括処理() Dim Fpath As String Dim Fname As String Dim Wb As Workbook Fpath = ThisWorkbook.Path & "\" Fname = Dir(Fpath & "*.xlsm") Do Until Fname = "" If Fname = ThisWorkbook.Name Then Else Application.DisplayAlerts = False 'ブックを開く Set Wb = Workbooks.Open(Fpath & Fname) 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" Wb.Close SaveChanges:=True Application.DisplayAlerts = True End If Fname = Dir() Loop End Sub 一括処理の実行をすると、フォルダ内の一つのファイルだけ マクロ実行されると終了してしまいます。 各々のファイルには他にもマクロを登録していて、そちらは 'マクロ実行 Application.Run "'" & Fname & "'!値貼り付け" のマクロの名前部分を変更して、同様に一括処理していますが 問題なく動きます。 なぜかこの「値貼り付け」のマクロだけ全ファイルに動作して くれません。 色々自分なりに調べているのですが、どうしても原因不明で 今回投稿させて頂きました

  • マクロ　エクセル２００３

    いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか？宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile　& ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub

  • workbookオブジェクトのクリアについて

    下記のコードはtest.xlsxを開き、ABCにセットして、開いたtest.xlsxを閉じた後、 ABCを参照しようとするコードです。 しかし、(4)でオートメーションエラーが発生します。 (3)のtest.xlsxを閉じるコードを 削除した場合うまくいきます。 開いたtest.xlsxを閉じた場合はABCにセットしたtest.xlsxもクリアされてしまうものなのでしょうか？ 私のオブジェクトの認識では、エクセルファイルをオブジェクトにセットした場合はセット元のエクセルファイルは閉じてもworkbookオブジェクトのABCに保持されていると思っています。 ※test.xlsxを閉じたい理由は以降のコードで同名ファイルを開きたいからです。 よろしくお願い致します。 Sub a() Dim ABC As Workbook Workbooks.Open (ThisWorkbook.Path & "\" & "test.xlsx") '(1) Set ABC = Workbooks("test.xlsx") '(2) Workbooks("test.xlsx").Close savechanges:=False '(3) ThisWorkbook.Worksheets("Sheet1").Range("A1").Value = ABC.Worksheets("Sheet1").Range("A1").Value '(4) End Sub

  • EXCEL2000とEXCEL2003のVBAについて

    現在、EXCEL2000で下記のコードを実行しています。 が、EXCEL2003で実行すると、 .UsedRange.Copy myb のコードが実行されているのにコピー出来ていません。 ファイルは開いていて、エラーは出ていないのです。 問題点わかる方教えていただけますか？ Sub 日別データ読込() Dim rngsaki As Range Dim pathmacrobook As String Dim namebook As String Dim motobook As Workbook Dim myb As Variant Set rngsaki = Workbooks("残高集計用.xls").Worksheets(3).Range("a2") pathmacrobook = ThisWorkbook.Path & "\CSV読込データ12\" namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set motobook = Workbooks.Open(pathmacrobook & namebook) Set myb = Workbooks("残高集計用.xls").Worksheets(3).Range("A65536").End(xlUp) With motobook.Worksheets("Sheet1") .UsedRange.Copy myb End With motobook.Close False namebook = Dir() Loop MsgBox "完了しました" End Sub

  • VBAの質問です。

    VBAの質問です。 以下のプログラムで、４列おきにコピーしたい時はどうすればいいでしょうか？ １つのフォルダの中に集約第１期・集約第２期・集約第３期という名前の３つのファイルがあり、 その３つのファイル全てに「結果」というシートがあります。 この「結果」シートのC4:AU37の数値をコピーします。 コピーした数値を、集約第３期のファイルの中にある「集計用シート」のC2から貼り付けしていきたいのですが、 この時に、４列おきにはりつけたいと思っています。 集約第１期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C２の列から４列おきに 集約第２期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C３の列から４列おきに 集約第３期ファイル-結果-C4の列→集約第３期ファイル-集計用シート-C４の列から４列おきに といった具合です。 集約第３期ファイル-集計用シート-C５の列は空白し、C６からまた貼り付けます。 どこをどう直せば良いでしょうか？ Sub データ抽出() Dim i As Long Dim flg As Boolean Dim myWb As Workbook Dim myWbName As String Application.ScreenUpdating = False ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path ThisWorkbook.Worksheets("集計用シート").Range("C2:EG35").Clear For i = 1 To 3 flg = False myWbName = "集約第" & i & "期.xls" If myWbName <> ThisWorkbook.Name Then For Each myWb In Workbooks If myWb.Name = myWbName Then flg = True Next myWb If flg = False Then Workbooks.Open Filename:=myWbName Else Workbooks(myWbName).Activate MsgBox myWbName & "を閉じてから再実行してください。" Exit Sub End If End If Worksheets("結果").Range("C4:AU37").Copy ThisWorkbook.Worksheets("集計用シート").Range("C2").Offset(, 45 * (i - 1)).PasteSpecial Paste:=xlPasteValues If myWbName <> ThisWorkbook.Name Then Application.DisplayAlerts = False Workbooks(myWbName).Close SaveChanges:=False Application.DisplayAlerts = True End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

  • Excel VBA連続コピー、貼付処理について

    特定のフォルダ内に格納されている複数のExcelファイルの「sheet1」シートのデータを 所定のExcelファイルにコピー＆ペーストしたいのですが、うまくいきません。 （貼付先のファイルを閉じようとするとエラーが発生します。） どうすればできるようになるでしょうか? ご教授の程よろしくお願いいたします。 -------------------------------------------------------------------- Sub copy_test() Dim myPath As String Dim copyFile As String Dim pasteFile As String Dim n As Long myPath = "C:\copy\" copyFile = Dir(myPath & "*.xls*") pasteFile = "C:\paste\paste_data.xlsx" n = 2 Do Until copyFile = "" Workbooks.Open Filename:=myPath & copyFile Workbooks(copyFile).Worksheets("sheet1").Range("A2:L201").Copy Workbooks.Open Filename:=pasteFile 'Workbooks(pasteFile).Worksheets("paste_data").Active Range("B1").Select Selection.End(xlDown).Select Selection.End(xlToLeft).Select Selection.End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveSheet.Paste ActiveWorkbook.Save Workbooks(pasteFile).Close False Application.CutCopyMode = False Workbooks(copyFile).Close False n = n + 999 copyFile = Dir() Loop End Sub ---------------------------------------------------------------------------------

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する