EXCEL VBA 数式を含めたコピー貼り付け
- VBAを使用してブック間で数式を含むコピー貼り付けをしたいです。
- 特定のシートのデータを担当者ごとにファイル分割し、数式を保持したまま貼り付けたいです。
- 現在のコピーペーストでは値が貼り付けられてしまうため、コピーペーストのロジックを修正したいです。
- ベストアンサー
EXCEL VBA 数式を含めたコピー貼り付け
お世話になります。 VBAを使ってブック間でコピー貼り付けするロジックを以前ご教授いただきましたが、結果が値貼り付けになってしまうため、数式を含めたコピー貼り付けをしたいのです。 A.xlsxというブックがあります。 この中に[データ]と[作業用]という2つのシートがあります。 [データ]シートに会社の1ヶ月の売上げデータが貼り付けています。 [作業用]シートのボタンを押したら[データ]シートのデータをA列に入っている担当者毎にファイルを分割してC:\dumy配下に作成するロジックを色々な方からご教授いただきまして作成しました。 動きはまったく問題ないのですが、下記ロジックの「ここ」部分でのコピーペースト時に値貼り付けしてしまっているため[データ]シートにあった数式がC:\dumy配下に出来上がったファイルには数式がなくなってしまう状態です。 数式も含めて全て貼り付けたいのですが、下記ロジックの[ここ]部分をどのように変更してよいのかが分りません・・ どなたかご教授いただけますでしょうか? よろしくお願い致します。 Sub ボタン_Click() Dim s0 As Worksheet Dim h Application.ScreenUpdating = False Worksheets("データ").Copy before:=Worksheets(1) Set s0 = Worksheets(1) Do Until Application.CountA(s0.Range("A:A")) < 2 h = s0.Range("A2").Value s0.Range("A1").AutoFilter field:=1, Criteria1:=h With Worksheets.Add ここ→ s0.AutoFilter.Range.Copy Destination:=.Range("A1") .Name = h .Move ActiveWorkbook.SaveAs Filename:="C:\dumy\" & h & ".xlsx" ActiveWorkbook.Close False s0.AutoFilter.Range.Offset(1).Delete shift:=xlShiftUp End With Loop Application.DisplayAlerts = False s0.Delete MsgBox "データをEXCELに表示します。" End Sub
- yakkun2338
- お礼率77% (325/418)
- Excel(エクセル)
- 回答数1
- ありがとう数1
- みんなの回答 (1)
- 専門家の回答
質問者が選んだベストアンサー
私のバージョンは2007です。VBAは独学なので間違っているかもしれませんが。 Copy DestinationのDestinationを使用すると値だけのコピーになるので、copyだけにしてみましたが、値だけしかコピー出来ませんでした。 どうもwith worksheet内のcopyでは無理だと判断しました。 オートフィルを使用しない下記方法では数式もコピー可能です。 Sub sample() Dim s0, nwk As Worksheet Dim h Dim i, j, LastRow, cnt As Long Application.DisplayAlerts = False Worksheets("データ").Copy before:=Worksheets(1) Set s0 = Worksheets(1) Do Until Application.CountA(s0.Range("A:A")) < 2 h = s0.Range("A2").Value '検索ワードの変数hと同じ文字のセル数取得 cnt = WorksheetFunction.CountIf(s0.Range("A:A"), h) i = cnt + 1 With s0 Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h End With Set nwk = Worksheets(h) 'データシートのA列の最終行取得 LastRow = s0.Cells(Rows.Count, 1).End(xlUp).Row j = LastRow '1行目コピー s0.Range("A1:C1").Copy nwk.Range("A1") Do Until j = 1 'A列のセルデータが変数hと同じ場合コピペ及び行削除 If s0.Cells(j, 1).Value = h Then s0.Range("A" & j & ":C" & j).Copy nwk.Range("A" & i) i = i - 1 s0.Rows(j).Delete End If j = j - 1 Loop With nwk .Move ActiveWorkbook.SaveAs Filename:="C:\dumy\" & h & ".xlsx" ActiveWorkbook.Close False End With Loop s0.Delete Application.DisplayAlerts = False MsgBox "データをEXCELに表示します。" End Sub 下記のs0シートのコピー元セル列2ケ所を修正下さい。現状A~C列になっています。 コピー後のデータは行削除にしてあります。ダミーシートをコピーされてるようですから問題ないと思いますが、支障あれば修正下さい。 1行目コピー s0.Range("A1:C1").Copy nwk.Range("A1") Do Until j = 1 'A列のセルデータが変数hと同じ場合コピペ及び行削除 If s0.Cells(j, 1).Value = h Then s0.Range("A" & j & ":C" & j).Copy nwk.Range("A" & i)
関連するQ&A
- EXCEL VBA 数式を含めたコピー貼り付け
お世話になります。 こちらのサイト内にありました、以前の質問QNo.8966520に対する以下の回答(http://qa.itmedia.co.jp/qa8966520.html)を参考にしているところですが、このVBAでは、A列に入っているデータ毎に新規ファイルを作成・保存するような処理となっているようですが、仮にデータを分類する基準を現在のA列を基準としたものから、B列にする場合は、どの記述をどのように変更すればよろしいでしょうか。 これに加えての質問ですが、仮にA.xlsxという元ブックがあると仮定し、この中に[データ]と[単価]という2つのシートがあるとします。以下のVBAの記述では[データ]シートのデータをA列ごと分類し、それを新規ブックに保存させるものですが、これに合わせて[単価]シートのデータ(シート内のデータは加工の必要なし)も新たに作成するブックにコピーし、保存するには、どのような記述を追加すればよろしいでしょうか。最終的には、新規作成ブックに、[データ]と[単価]の2つのシートが作成されるようにしたいと思います。 [単価]シートのデータを、[データ]シートのデータと合わせて新規ブックにコピーする目的は、[データ]シートのデータの一部に、[単価]シートのデータを参照する数式が入っており、[作業用]シートのデータの抽出・保存だけでは、[作業用]シート内の数式が不完全な状態となってしまうためです。 どなたかご教授いただけますでしょうか? よろしくお願い致します。 Sub sample() Dim s0, nwk As Worksheet Dim h Dim i, j, LastRow, cnt As Long Application.DisplayAlerts = False Worksheets("データ").Copy before:=Worksheets(1) Set s0 = Worksheets(1) Do Until Application.CountA(s0.Range("A:A")) < 2 h = s0.Range("A2").Value '検索ワードの変数hと同じ文字のセル数取得 cnt = WorksheetFunction.CountIf(s0.Range("A:A"), h) i = cnt + 1 With s0 Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = h End With Set nwk = Worksheets(h) 'データシートのA列の最終行取得 LastRow = s0.Cells(Rows.Count, 1).End(xlUp).Row j = LastRow '1行目コピー s0.Range("A1:C1").Copy nwk.Range("A1") Do Until j = 1 'A列のセルデータが変数hと同じ場合コピペ及び行削除 If s0.Cells(j, 1).Value = h Then s0.Range("A" & j & ":C" & j).Copy nwk.Range("A" & i) i = i - 1 s0.Rows(j).Delete End If j = j - 1 Loop With nwk .Move ActiveWorkbook.SaveAs Filename:="C:\dumy\" & h & ".xlsx" ActiveWorkbook.Close False End With Loop s0.Delete Application.DisplayAlerts = False MsgBox "データをEXCELに表示します。" End Sub
- ベストアンサー
- Excel(エクセル)
- Excel VBAについてご教ください
いつも、こちらのサイトをみながら、VBAを勉強させていただいているのですが、 今回、自分のやりたいことが見当たりませんでしたので、ご教示いただければと思います。 やりたいことは、 (1)「エリア1」にある名称ごとに同じBookの別シートに振り分け (2)各シートで「累計売上」順(降順)に並べ替え の2つの作業を同時に行いたいのです。 また、 (1)には、あらかじめ決まったシートが用意されているので、 そのシートの決められた範囲にデータを移したいのと、 データを貼り付ける前に、前に残っている前回のデータを削除してから、同場所に貼り付けを行いたいです。 ちなみに、エリアが3つあるので、シートも3枚あります。 自分でも、いろいろとやってみて、 下記のようなコードを書いたのですが、あまりにも重くて、動きがわるかったため、 シンプルかつ、軽やかに動くコードの書き方をお教えいただければと思います。 よろしくお願いいたします。 Sub Macro2() Application.ScreenUpdating = False With Worksheets("元データシート") .Range("A5").AutoFilter _ Field:=9, _ Criteria1:="京前", Operator:=xlAnd .Range("F4:P65500").Copy _ Worksheets("前 品別").Range("AJ5") .AutoFilterMode = False .Range("A5").AutoFilter _ Field:=9, _ Criteria1:="京中", Operator:=xlAnd .Range("F4:P65500").Copy _ Worksheets("中 品別").Range("AJ5") .AutoFilterMode = False .Range("A5").AutoFilter _ Field:=9, _ Criteria1:="京後", Operator:=xlAnd .Range("F4:P65500").Copy _ Worksheets("後 品別").Range("AJ5") .AutoFilterMode = False End With Application.ScreenUpdating = True MsgBox "各地区シートにデータを振分けました。" End Sub 【元データの形式は以下のような形になってます。】 A B C D E F G H I J 4 コード S番号 S名称 S名 月間個数 月間売上 累計個数 累計売上 エリア1 エリア2 5 4237 4025 AAA あああ 3 150 7 350 京後 後A 6 6769 4025 AAA いいい 2 100 5 250 京中 中B 7 3453 4028 BBB ううう 5 50 5 50 京後 後C 8 4252 4029 CCC えええ 1 110 9 990 京前 前A 9 3564 4027 DDD おおお 0 0 8 80 京前 前A 10 8035 4022 EEE かかか 1 30 2 60 京中 中B 11 9225 4026 EEE ききき 2 40 3 60 京後 後A 以下5000行ぐらいデータが続きます。
- ベストアンサー
- オフィス系ソフト
- VBA エクセルでオートフィルタをされているデータ
エクセルでオートフィルタをされているデータを 昇順で並べ替えするコードを取得したのですが ActiveWorkbook.Worksheets("置換").AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets("置換").AutoFilter.Sort.SortFields.Add Key:=Range("A1:A5203"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("置換").AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With なのですが どれが並べ替えのコードなのでしょうか? ActiveWorkbook.Worksheets("置換").AutoFilter.Sort.SortFields.Clear これはオートフィルタの並べ替えを解除するコードだと思いますが ActiveWorkbook.Worksheets("置換").AutoFilter.Sort.SortFields.Add Key:=Range("A1:A5203"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal これは何のコードでしょう?
- ベストアンサー
- Excel(エクセル)
- オートフィルタで抽出したデータをVBAで貼り付けしたい
質問させていただきます。 エクセルで仕入帳を作っています。 各取引先ごとに1枚のシートになっているのですが、 該当する月をオートフィルタで抽出して、そのデータを1枚のシートに貼り付けていき、各月ごとにデータをまとめたいと思っています。 ユーザーフォームで月を入力してオートフィルタで抽出しているのですが、データのないシートの場合不要な部分までコピー&ペーストされてしまいます。 これを回避するにはどのようにコードをかけばいいのでしょうか。 よろしくお願い致します。 現在はこのようなコードで抽出しています。 Private Sub CommandButton1_Click() Application.ScreenUpdating = False Worksheets("sheet2").Select Range("H1:H17").Select Range("H17").Activate Selection.AutoFilter Field:=8 Rows("2:2").Select Rows("2:500").Select Selection.ClearContents RowIndex = 3 '行番号の初期値設定 Do While Worksheets("目次").Cells(RowIndex, 1).Value <> "" '拾ったセルの値が空でない間ループ内の処理をする 検索値 = UserForm1.TextBox1.Text DataSheetName = Worksheets("目次").Cells(RowIndex, 1).Value Worksheets(DataSheetName).Select Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.AutoFilter Selection.AutoFilter Field:=13, Criteria1:=検索値 & "月分" Set tbl = ActiveCell.CurrentRegion tbl.Offset(2, 0).Resize(tbl.Rows.Count - 2, tbl.Columns.Count).Select Selection.Copy Worksheets("sheet2").Select IRow = Range("A" & Rows.Count).End(xlUp).Row Range("A" & IRow + 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Worksheets(DataSheetName).Select Selection.AutoFilter Field:=13 RowIndex = RowIndex + 1 '行番号カウントアップ Loop Application.ScreenUpdating = True Worksheets("sheet2").Select Range("A2").Select Unload UserForm1 End Sub
- ベストアンサー
- オフィス系ソフト
- Excel VBAについて教えて下さい。
00というブックとテストというブックがあります。 00のデータを並び替え、一部変更し、テストのシート3へ貼付けを行いたいのですが、 うまく作動してくれません。以下に現在のコードを記載しましたので、ご指摘いただければと思います。 やりたいことは 1.ブック”00”のシート00にて条件がF列が0、E列がHでソートをかけます。 2.E列のHをすべて数字の1に変更します。 3.今度は別の条件、F列が1、E列がH、D列が1でソートをかけます。 4.E列のHをすべて消去します。 5.すべて表示させA列からE列までのデータを、テストのシート3へ貼付けをします。 コピー&ペーストは上手くいくのですが、肝心のソート+文字の変更+消去が出来ていません。 ネットを見ながら書いたコードで、VBAを勉強中です。 よろしくお願いします。 あと、この作業の前にブック00のB列にて昇順のソートをかけるというコードを追加したいのですが、 それについても教えていただけるとうれしいです。 よろしくお願い致します。 Private Sub Worksheet_Activate() Dim wb1 As Workbook Dim wb2 As Workbook Dim i As Long Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("C:\Documents and Settings\デスクトップ\メモ\00.xls", ReadOnly:=True) With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", "1") End If Next i With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter Field:=4, Criteria1:="=" & "1", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", " ") End If Next i wb2.Sheets("00").Range("B1", .Cells(Rows.Count, 5).End(xlUp)).Copy wb1.Sheets("Sheet3").Range("K3").PasteSpecial wb2.Close False Range("A1").Select Application.ScreenUpdating = True End With End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでコピーして 手動で貼り付け
こん○○は 初心者であちこちからコードをコピペしてなんとかつなぎ合わせているレベルです。 エクセル2002 OS XP Sub copy() i = Worksheets(3).Range("I2") 'I2に適当な数字が入ってる i = i + 1 左上 = "G1" '選択する範囲の左上セル 右下 = "H" & i ' 〃 右下セル 範囲 = 左上 & ":" & 右下 Worksheets(3).Range(範囲).copy_ Worksheets(3).Range("n1").PasteSpecial Paste:=xlPasteValues i = (i + 1) / 2 左上2 = "N1" 右下2 = "O" & i 範囲2 = 左上2 & ":" & 右下2 Worksheets(3).Range(範囲2).copy End Sub というコードでコピーした状態にした後手動で他のエクセルやテキストに貼り付けようとしています。ただしシート3は Private Sub auto_Open() ActiveWorkbook.Unprotect Worksheets("Sheet1").Visible = False Worksheets("Sheet3").Visible = False ActiveWorkbook.Protect End Sub でみえなくしています。 こうすると他のエクセルに貼り付けると 貼り付け先のシートが消えてしまいます。消えないようにしたいのですが。 なんとかお知恵を拝借できませんでしょうか?よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでオートフィルタの結果をコピーして別シートに貼り付け
よろしくお願いします。今下のようにコードを書いています。 見よう見まねですが・・・。 追加情報の範囲をデータシートのデータのある最終行の下に 入れるものなのですが、 追加情報シートでオートフィルタをかけてから、その結果を 貼り付けたいのですが、コードをどのようにつなげたらいいか 教えていただけないでしょうか。 追加情報シートのBD列で、0より大きい値を抽出して、それを 元の(下のコード)のようにサイズを変更して、貼り付けたいと思います よろしくお願いします。 With Worksheets("追加情報").Range("AA1").CurrentRegion .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2).Copy End With Worksheets("データ").Range("C65536").End(xlUp).Offset(1). _ PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Sub オートフィルタ() Range("BD1").Select Selection.AutoFilter Selection.AutoFilter Field:=30, Criteria1:=">0", Operator:=xlAnd End Sub
- ベストアンサー
- オフィス系ソフト
- VBAがうまく動きません。
エクセルVBAで実行時は正確に動かないが、ステップインでは正常に作動するのはなぜですか? 入力シートに入力された情報を元にデータシートから抽出を行い、新規シートを開き、そこでリストにしたい情報のみを編集(不要なタイトル行などの削除)して、自動で貼り付けと名前の定義を行うマクロを作っています。 ステップイン[F8]や実行[F5]では正常に作動するのですが、実際に使用してみると、抽出データが貼り付けされていない状態(セルは空白)となりますが、名前の定義は抽出データと同じ行まで定義されているので、貼り付けのみ上手くいっていないように思われます。 下記が作成したコードです。情報が足りないようでしたら、申し訳ありません。 お手上げ状態となっていますので、お力添えいただけると幸いです。 Dim syurui as String Dim suuryou as Integer Dim target as Range Private Sub Worksheet_Change(ByVal target As Range) If Intersect(target, Range("D7")) Is Nothing Then Exit Sub Else Call 抜出 End If End Sub Sub 抜出() Worksheets("データ").Activate ’後に出てくる名前初期化でエラーを防ぐため仮定義 ActiveWorkbook.Names.Add Name:="番号", _ RefersTo:=Worksheets("データ").Range("K2") syurui = Worksheets("入力").Range("D9").Value Worksheets("データ").Select Set target = Worksheets("データ").Range("M2") With Worksheets("データ").Range("D1") .AutoFilter field:=4, Criteria1:=syurui .CurrentRegion.SpecialCells(xlVisible).Copy With Worksheets.Add .Paste ’不要な行を削除 .Rows(1).Delete .Range("A:D").Delete .Range("B:F").Delete ’抽出した情報を貼り付け&新規シート削除 .UsedRange.Copy target Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With .AutoFilter End With ’抽出データの最終行を調べる suuryou = Worksheets("データ").Cells(65536, "M").End(xlUp).Row If suuryou = 1 Then Worksheets("入力").Activate Exit Sub Else Range("番号").Name.Delete ActiveWorkbook.Names.Add Name:="番号", _ RefersTo:=Worksheets(”データ").Range("M2:M" & suuryou) End If Worksheets("入力").Activate End Sub
- 締切済み
- Visual Basic
- エクセルVBA:コピーの貼り付け先
VBA初心者です。よろしくお願いします。 あるデータベースをセルB2に入力されている値で絞込み、 シート2に貼り付けるとき、下記の(1)がおそらく正解だと思いますが、 ★(質問1) (2)でも同じ結果が得られました。コピー先の目的地を示す「Destination:=」の部分は省略して全く問題なしと考えてよろしいのでしょうか? ★(質問2) (3)で試してみても同じ結果が得られました。range("sheet2!A1") なんて書き方は、たまたま、試してみたらできちゃった(同じ結果が得られた)のですが、使い方として問題ありませんか? ------------------------------------------------------------- (1) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Destination:=Sheets("Sheet2").Range("A1") .AutoFilter End With End Sub -------------------------------------------------------------- (2) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Sheets("Sheet2").Range("A1") .AutoFilter End With End Sub -------------------------------------------------------------- (3) Sub test01() With Range("A1") .AutoFilter field:=2, Criteria1:=Range("B2") .CurrentRegion.Copy Range("Sheet2!A1") .AutoFilter End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル VBA 繰り返し コピー貼り付け
以下を繰り返し作業をOffsetを使用して行いたいのですがどうすればいいでしょうか? Sheets("Sheet1").Select Range("A1:C1").Select のA1:C1以下へA1000:C1000ぐらいあります。 Sheets("Sheet2").Select Range("G1").Select は貼り付けたセル3つの数字の組み合わせで公式に使う計算期間がまちまちですので公式を張り付けたり出来ません。 D1の解を heets("Sheet1").Select Range("D1").Select に貼り付けてA1:C1以下1000までの結果を評価出来るようにしたいのですが! ' Macro1 Macro Sheets("Sheet1").Select Range("A1:C1").Select Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D1").Select ActiveSheet.Paste Range("A2:C2").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D2").Select ActiveSheet.Paste Range("A3:C3").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("D1").Select ActiveSheet.Paste Range("G1").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet1").Select Range("D3").Select ActiveSheet.Paste End Sub よろしくおねがいします。
- ベストアンサー
- オフィス系ソフト
お礼
dogs_catsさん、ご連絡ありがとうございました!! 連休に入ってしまいご連絡が遅くなりまして申し訳ございませんでした。 ご教授いただきましたロジックにて思い通りの動きになりました! 本当にありがとうございました!!助かりました。 いつも細かくご丁寧なご説明、ありがとうございます!! このたびはありがとうございました。