EXCEL VBA 数式を含めたコピー貼り付け

質問

お世話になります。

VBAを使ってブック間でコピー貼り付けするロジックを以前ご教授いただきましたが、結果が値貼り付けになってしまうため、数式を含めたコピー貼り付けをしたいのです。

A.xlsｘというブックがあります。
この中に[データ]と[作業用]という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

回答No.1

dogs_cats · ベストアンサー

私のバージョンは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シートのコピー元セル列２ケ所を修正下さい。現状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)

お礼

dogs_catsさん、ご連絡ありがとうございました！！
連休に入ってしまいご連絡が遅くなりまして申し訳ございませんでした。

ご教授いただきましたロジックにて思い通りの動きになりました！
本当にありがとうございました！！助かりました。

いつも細かくご丁寧なご説明、ありがとうございます！！
このたびはありがとうございました。