エクセルマクロの簡素化について

このQ&Aのポイント
  • エクセルマクロを使用してデータのコピペを行っているが、非常に手間がかかっている。
  • ファイル名、コピー元、コピー先の一覧を作成し、修正することで簡素化できる。
  • マクロを使ってコピペを行う際に、アイテムごとに50個のファイルがある。
回答を見る
  • ベストアンサー

エクセル マクロ 簡素化

マクロ初心者です。 下記のデータのコピペする、マクロを使用しています。 下記にはAAAとBBBの2つのエクセルへのコピペのみしか記述していませんが、 その下に50ファイル分のファイル名、コピー元、コピー先だけが違うマクロが並んでいます。 メンテナンスや更新に手作業で行っているので、非常に時間がかかります。 例えば、別のシートにファイル名、コピー元、コピー先の一覧を作成し、 そのシートでファイル名、コピー元、コピー先を修正し、コピペができるようになるなど、 どうにかして簡素化したいのですが、どのように実現すればいいか、教えてくださると助かります。 ---------------------------------------------------------------------- Private Sub CommandButton1_Click()   Dim wb As Workbook Application.ScreenUpdating = False Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\AAA.xls", UpdateLinks:=0) ThisWorkbook.Sheets("BBB").Range("A1:B1").Copy wb.Sheets("CCC").Range("A1:B1").PasteSpecial (xlPasteValues) Application.CutCopyMode = False Application.DisplayAlerts = False wb.Close (True) Application.DisplayAlerts = True Application.ScreenUpdating = True Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\BBB.xls", UpdateLinks:=0) ThisWorkbook.Sheets("BBB").Range("A2:B2").Copy wb.Sheets("CCC").Range("A2:B2").PasteSpecial (xlPasteValues) Application.CutCopyMode = False Application.DisplayAlerts = False wb.Close (True) Application.DisplayAlerts = True Application.ScreenUpdating = True 'アイテム名、コピー元、コピー先、だけがちがう、同じようなマクロが50ファイル分ある。 End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.1

質問の内容がはっきりしない。補足してください。 エクセルの扱う要素としては、(1)ブック(2)シート(3)セル範囲(行、列、範囲)(4)値、書式などありますが、 (3)は自動で取得できたりするが、 3つともバラバラに変わるのですか。出来ればシート名ぐらい統一したい。商品1、商品2と先頭だけでも共通にして、対象外はその名前(商品XX)を避ける。 そういう点から質問を書けば、どういう文章表現になるかな。 それと1ブックの中で本件で取り扱うシートは単数か、複数か? ブックは同じホルダにあると考えて良いのか?。むしろ1つになるよう設計すべきだ。 単数か複数かは、質問するとき、いつも考えて、質問文ではっきりさせてください。 それとコピー先は1ブック1シートに、集約(直積)していくのか(コピペ=移す・増やすだけ)どうか、質問にはっきり書いていますか? よくある質問から推測して、集積ではないかと想像するが。 ーー 基本的にシートの列にブック名、シート名、セル範囲を入力しておく。 もちろん同一行で1セットであるべきです。 そのデータを元に、繰り返し文で順次繰返せば仕舞いの話。 繰返すルーチンに入る前に、ブック名、シート名、範囲を示す文字列に上記のブック名等の値をセットして、質問文にあるコードの実行ルーチンに入る。 ーー  開始の用意(初期設定)  For Nextなどの繰り返し  ブック名=XXX  <--以下3項目は決ったシートの列から Filename:=の個所  シート名=YYY Sheets("BBB").の個所  範囲=ZZZ(コピー元) Range("A2:B2").の個所  メイン 処理  ブック名など取得のセル移動  次の繰り返しサイクルへ

関連するQ&A

  • エクセル マクロ 値の貼り付け

    以下のエクセルのマクロで値のみを貼り付けたいのですが、.valueを指定しても上手くできません。 どのように修正すればいいか教えてください。 Dim wb As Workbook Application.ScreenUpdating = False Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\ファイルA.xls", UpdateLinks:=0) ThisWorkbook.Sheets("BBB").Range("E4:AR4").Copy wb.Sheets("BBB").Range("E4:AR4") Application.DisplayAlerts = False wb.Close (True) Application.DisplayAlerts = True Application.ScreenUpdating = True

  • エクセルマクロ  リンクダイアログのスルー

    下記のVBAを作成し、動かしているのですが、 Office2002以降では、問題なく動くのですが、Office2000では、コピー先のファイルを開く際に、リンクのダイアログが表示されます。 コピー先ファイルのリンクを削除したらよいのですが、どうしても見つかりません。 なので、下記のマクロにリンクダイアログをスルーするようにしたいのですが、どのようにすればよいか教えてください。 Private Sub CommandButton1_Click() Dim wb As Workbook Application.ScreenUpdating = False Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\AAA.xls") ThisWorkbook.Sheets("BBB").Range("E4:AR4").Copy wb.Sheets("CCC").Range("E4:AR4") Application.DisplayAlerts = False wb.Close (True) Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

  • エクセル マクロ 

    以下のマクロを作成し Fnameを開き、そのファイルで特定の文字列を探し、Offsetしたセルの値のコピー&ペーストをしようとしています。 しかし、ファイルは開くのですが、コピー&ペーストをいません。 どのようにすれば、実行できるのでしょうか? 変数やOffsetの使い方が違うと思うのですが、教えてください。  Dim Wbk As Workbook Dim Fname As String Dim f As Integer For f = 1 To 100 ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path Fname = Cells(f, 1).Value & ".xls" Application.ScreenUpdating = False Workbooks.Open (Fname), UpdateLinks:=0 Set Obj = Worksheets(Cells(f, 2).Value).Cells.Find(Cells(f, 3).Value) Obj.Offset(24, 0).Copy Obj.Offset(36, 0).PasteSpecial (xlPasteValues) Application.CutCopyMode = False Application.DisplayAlerts = False Workbooks(Fname).Close SaveChanges:=True Application.DisplayAlerts = True Application.ScreenUpdating = True Next f

  • Excelマクロについての質問です。

    Excelのマクロについての質問です。 マクロについての質問です。 以下のようなマクロを作成しました。 このマクロを動作させているのはこのマクロを作成したファイル上です。 Sub Macro9() Dim WBA As Workbook Dim WBB As Workbook Dim WSA As Worksheet Dim WSB As Worksheet Set WBA = Workbooks("A") Set WBB = Workbooks("B") Set WSB = WBB.Worksheets("1") For i = 100 To 3000 Step 20 Worksheets.Add Before:=Worksheets("Sheet1") Dim k As String k = i ActiveSheet.Name = (k / 100) Set WSA = WBA.Worksheets(k / 100) WSB.Range("A1:AY30").Copy Destination:=WSA.Range("A1") WSA.Range("D4:I30").Clear WSA.Range("Q4:V30").Clear WSA.Range("AD4:AI30").Clear WSA.Range("AQ4:AV30").Clear Next i Application.DisplayAlerts = False Sheets("Sheet1").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet2").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet3").Delete Application.DisplayAlerts = True End Sub そこで質問ですが、このマクロを作動させると何のエラーの表示もなく最後まで動作は完了します。 ですが、シートの作成は30まで作成できてもその後のセルのコピー&ペーストはなぜかシート6.8までしかできていません(7~30までのシートはシート作成はできているのですがコピペのみが実行されず空白のままになっています。) シートもコピペも両方ともシート30まで完了するにはどの点を改善すればいいのでしょうか? 知恵が足りずどうしても直す事が出来ません。 長文申し訳ございませんが是非皆さまのお知恵をお貸しください。 宜しくお願い致します。

  • ブックの統合について

    Sub 集計() Application.ScreenUpdating = False fldPath = ThisWorkbook.Path & "\" fname = Dir(fldPath & "*.xls") Do Until fname = Empty If fname <> ThisWorkbook.Name Then Workbooks.Open fldPath & fname mx = Application.WorksheetFunction.Max(Sheets("1日").Columns(1)) lr = Sheets("1日").Range("B65536").End(xlUp).Row FR = ThisWorkbook.Sheets("1日").Range("B65536").End(xlUp).Row + 1 Sheets("1日").Rows("6:" & lr).Copy Application.DisplayAlerts = False ActiveWorkbook.Close (False) Application.DisplayAlerts = True ThisWorkbook.Sheets("1日").Cells(FR, 1).Select ActiveSheet.Paste Application.CutCopyMode = False End If fname = Dir Loop Application.ScreenUpdating = True End Sub 上記のようにマクロを組みましたが、集計したいシートがたくさんある為 シートごとにマクロを組みなおさなければなりません。 そこで、 集計するシートと集計されるシートのシート名が一緒の時、 わざわざsheets("1日")と書き直さなくても "Activesheetと同じシート名"のようなマクロの組み方は出来るのでしょうか。

  • worksheetsの名前変更マクロ

    マクロでsheetsをコピーしてそのあと名前を変更するマクロを作っているのですがうまくいきません。 マクロで他のbookを開いて、そのbook名をsheets名にしたいのですが以下のマクロではうまくいきませんでした。どこが悪いのでしょうか? ご指導お願いいたします。 Sub ~() OpenFileName = Application.GetOpenFilename("TXT/CSVファイル,*.txt?;*.csv?") ThisWorkbook.Activate Application.ScreenUpdating = False If OpenFileName <> "False" Then Set TargetBook = Workbooks.Open(OpenFileName) ThisWorkbook.Activate Worksheets("マクロ用名称変更不可").Copy before:=Worksheets("マクロ用名称変更不可") ActiveSheet.Name = OpenFileName TargetBook.Close Application.ScreenUpdating = True Else MsgBox "キャンセルしました" End If End Sub

  • アクセスへのエクセルファイルの一括取込みについて

    お世話になっております。 エクセルVBAで所定のフォルダのエクセルファイルから一つのシートにまとめるというマクロを作成しております。アクセスVBAでaccdbファイルで同じことをしたいのですが、アクセスは触ったことがなく、ご教示していただけないでしょうか。 以下エクセルでの取り込みマクロです(長いので一部割愛)。 ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub エクセル取り込み() Dim fpath, fname, buzai, bmst, hantei As String Dim buzaiflg As Boolean Dim wb As Workbook Dim sh1, sh2, sh3, sh4, sh5 As Worksheet Dim dlg As FileDialog Dim TCht As Chart Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set sh1 = ThisWorkbook.Worksheets("データまとめ") Set dlg = Application.FileDialog(msoFileDialogFolderPicker) ' キャンセルボタンクリック時にマクロを終了 If dlg.Show = False Then Exit Sub ' フォルダーのフルパスを変数に格納 fpath = dlg.SelectedItems(1) & "\" Application.DisplayAlerts = False i = 5 pcnt = 2 fname = Dir(fpath & "*.xl*", vbNormal) Do Until fname = "" Set wb = Workbooks.Open(fpath & fname, UpdateLinks:=0) Set sh2 = wb.Worksheets(1) i = i + 1 sh1.Range("A" & i).Value = i - 5 sh1.Range("B" & i).Value = fname sh1.Range("C" & i).Value = sh2.Range("A6").Value sh1.Range("D" & i).Value = sh2.Range("D6").Value sh1.Range("E" & i).Value = sh2.Range("F6").Value sh1.Range("F" & i).Value = sh2.Range("K4").Value sh1.Range("G" & i).Value = sh2.Range("K5").Value sh1.Range("H" & i).Value = sh2.Range("A9").Value 割愛 wb.Close SaveChanges:=False fname = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "終了しました。" End Sub

  • 同一フォルダの複数ブックの値を取得マクロ

    エクセル2010のマクロで困っています。 同一フォルダ内・複数ブックの 「異動表」というシートの特定のセルを抽出し、一覧にするマクロを素人ながら作成しようとがんばっています。 下記、マクロを作成したのですが、 必ず、98件(98ブック)前後でマクロが止まってしまいます。 【Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。】←ここで止まります。 なぜなのでしょうか??ご教授願います。 Sub (1)() Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xlsx") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Sheets("異動表").Range("A1").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("a1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("b1").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("b1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("b4").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("c1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("m2").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("d1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("退職金計算書").Range("d21").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("e1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 Application.ScreenUpdating = True 'コピー先のセルの内容を置き換えますか?=YES Application.DisplayAlerts = False '警告表示を出さない Application.CutCopyMode = False 'クリップボードのコピーを消す wb.Close (False) '有無を言わずに保存せず閉じる For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば c.Value = c.Value '値に変更 End If Next n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 Dim ws As Worksheet '全てのシートの色をなしにする For Each ws In Worksheets ws.Tab.ColorIndex = xlColorIndexNone Next MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _ + Chr(&HD) + Chr(&HA) + "" _ + Chr(&HD) + Chr(&HA) + "", , "( ̄ー ̄)v " End Sub

  • エクセルのマクロで繰り返し処理

    当方マクロ初心者ですが下記のマクロをCheckBox0~CheckBox23についてコピーするセルを変化させながら繰り返し処理を行いたいのですが、簡単なループ処理で行えますか? 教えていただければ幸いです。 If CheckBox0.Value = True Then Worksheets("sheets1").Activate  行 = Worksheets("sheets1").Range("e7")   行 = 行   Worksheets("sheets1").Range("g7:t7").Copy Windows("Books1.xls").Activate Sheets("sheets1").Select Range(Cells(行, 15), Cells(行, 15)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End If

  • エクセルで、シートを非表示のままマクロを実行するには?

    エクセル初心者です。 Sheet1で、マクロの実行ボタンがあり、Sheet2で、データを編集して、 Sheet1に結果の一覧を表示させるマクロなのですが、 Sheet2は非表示のままマクロを実行したいのですが、うまくいかず、 Sheet2を表示して、実行するとうまくいくため、 一時的にシートを表示させるようにしてみたのですが、 Sheets("Sheet2").Range(Cells(2, 28), Cells(rowCnt, 37)).Insert Shift:=xlDown で、アプリケーション定義・オブジェクト定義エラーになります。 どなたかご指南下さい。 Private Sub EDITSLINF() Dim rowCnt As Long Application.ScreenUpdating = False Worksheets("製造記録一覧 (edit1)").Visible = True  Sheets("Sheet2").Range("AB2:AK300").ClearContents '追加レコード抽出&コピー&ペースト Sheets("Sheet2").Range("Q1:Z300").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "AP1:AP2"), CopyToRange:=Sheets("Sheet2").Range("AB1:AK1"), Unique:=False '既存レコードコピー&ペースト rowCnt = Sheets("Sheet2").Range("O1") Sheets("Sheet2").Range(Cells(2, 28), Cells(rowCnt, 37)).Insert Shift:=xlDown Sheets("Sheet2").Range(Cells(2, 28), Cells(rowCnt, 37)).Interior.ColorIndex = xlNone Sheets("Sheet2").Range(Cells(2, 2), Cells(rowCnt, 11)).Copy Sheets("Sheet2").Range("AB2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Worksheets("Sheet2").Visible = False 'メインシートへコピー   Application.CutCopyMode = False Sheets("Sheet2").Range("AB2:AJ300").Copy Sheets("Sheet1").Range("K4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False End Sub

専門家に質問してみよう