【VBA】元シートの内容を別シートへ転記する方法2

質問

添付のピクチャの様に、元シートが有ります。(行数は変動します)
元シートの数式・書式を維持したまま転記出来るコード
をご教示願います。既存のコードで特に困った点は、ピクチャのコメント部分です。

行いたい事は下記です。
-----------------------------------------------------------------------------
2シート目へ元シート1行目の見出しと品番010の行を転記
3シート目へ元シート1行目の見出しと品番222の行を転記
4シート目へ元シート1行目の見出しと品番222の行を転記
5シート目へ元シート1行目の見出しと品番033の行を転記
同様に、A列の最終の品番迄、繰り返しシートを作成
------------------------------------------------------------------------------
どうぞ宜しくお願い致します。

※「切り取り」で別シートを作成する方法でも結構です。

回答No.4

kkkkkm · ベストアンサー

>「 切り取り」で別シートを作成する方法

シート丸ごとコピーする場合は以下のように変更してください。新規シート作成時にすべての書式等は引き継がれます。

If shflg = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value
End If

の部分を

If shflg = False Then
Sh1.Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = c.Value
Sheets(c.Value).Cells.Clear
End If

お礼

kkkkkm様

こちらの補足にて、希望通りの結果となりました。
VBAの補足コメントは自分で考え、一部でも理解する様にします。
いつも有難うございます。

回答No.6

imogasi

画像例では０１０は２行（出ている）なのに、説明は１回、２２２は２回の例になっているが、意味は。
文章で、
・１行目の見出しと
・各行１行のデータを
・新（別）シートの第１－２行に持ってきたい
・表示形式と数式とコメントは新シートにも持ってきたい
　列幅もか？
・品番で重複するものは１つだけにする？複数シートを作る？
こういう風に、しっかりと、文章で表現できないのか。
ーー
質問者が、回答結果をそのままコピペして、試行して、チェックする、という態度がありありだが、VBAでやるとして、必要な要素コードを勉強する（増やす）という態度にしてほしい。回答者の役割は、この作業の下請けでなく、ヒントを提供するもの、にしてほしい。

回答No.5

HohoPapa

>1週間程お時間頂きますが、サンプルにて勉強、確認させて頂きます。
勉強するとのことであれば一言。

今回のように最上位の行から下方向に順番に処理する場合、
厳密には、For Each構文の使用は適切ではありません。
多くの場合（ほぼ例外なく）、作者の期待のとおりの順番に処理されますが
For Each構文の場合、処理順番が保証されないからです。

https://www.exvba.com/2260/
が参考になると思います。

回答No.3

kkkkkm

項目のセルの書式を忘れてデータ転記のままでした。

Sh2.Range("A1:E1").Value = Sh1.Range("A1:E1").Value
↓
Sh1.Range("A1:E1").Copy Sh2.Range("A1:E1")

に変更してください。

お礼

kkkkkm様

有難うございました。
1週間程掛かりますが、勉強・動作確認させて頂きます。

回答No.2

HohoPapa

タイトル行やデータ行の書式、計算式も複写したいとのことなので
行範囲を指定して複写するコードとしてみました。
各行の行高は複写されますが列幅は複写していません。
必要があれば指摘してください。

Sub bbb()
　Dim Insh As Worksheet
　Dim tgSh As Worksheet
　Dim SRow As Long '複写行範囲　自
　Dim ERow As Long '複写行範囲　至
　Dim RowCnt As Long

　Set Insh = ThisWorkbook.Sheets(1)　'複写元シートの指定
　RowCnt = 2
　SRow = 2
　ERow = 2

　Do
　　If Insh.Cells(RowCnt, 1).Value = "" Then Exit Sub
　　If Insh.Cells(RowCnt, 1).Value <> Insh.Cells(RowCnt + 1, 1).Value Then
　　　ERow = RowCnt
　　　Set tgSh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　tgSh.Name = Insh.Cells(SRow, 1).Text　 'シート名をセット
　　　Insh.Rows(1).Copy tgSh.Rows(1)　　'タイトル行を複写
　　　With Insh　　'データ行範囲を複写
　　　　Range(.Rows(SRow), .Rows(ERow)).Copy tgSh.Rows(2)
　　　End With
　　　SRow = ERow + 1
　　End If
　　RowCnt = RowCnt + 1
　Loop

End Sub

お礼

HohoPapa様

有難うございました。
1週間程お時間頂きますが、サンプルにて勉強、確認させて頂きます。

回答No.1

kkkkkm

前回のコードの転記の範囲を広げてコピー貼り付けに変更したものです。

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet, sh As Worksheet
Dim Sh1LastRow As Long, fRow As Long
Dim c As Range
Dim shflg As Boolean

Application.ScreenUpdating = False

Set Sh1 = Sheets("Sheet1")

Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row

fRow = 2
For Each c In Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "A"))
If c.Value <> c.Offset(1, 0).Value Then
shflg = False
For Each sh In Worksheets
If sh.Name = c.Value Then shflg = True
Next
If shflg = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value
End If
Set Sh2 = Sheets(c.Value)
Sh2.Range("A1:E1").Value = Sh1.Range("A1:E1").Value
Sh1.Range(Sh1.Cells(fRow, "A"), Sh1.Cells(c.Row, "E")).Copy Sh2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(c.Row - fRow + 1, 5)
Set Sh2 = Nothing
fRow = c.Offset(1, 0).Row
End If
Next
Sh1.Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set Sh1 = Nothing
End Sub