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

質問

1シート目のA列には品番が沢山並んでおり、B列、C列に内訳、D列に合計が有ります。例)参照
下記の処理をしたいです。
-------------------------------------------------------------------
2シート目へ1行目の見出しとAAAの品番の行を転記
3シート目へ1行目の見出しとBBBの品番の行を転記
同様に、A列最終行迄繰り返しシートを作成
-------------------------------------------------------------------

A列の品番が変わる行迄を一まとまりとして行選択する方法にて
コードをお教え頂きたく、宜しくお願いします。お教え頂いた内容は理解する様努めます。

例)
内訳1 内訳2 合計
AAA ○○○ ○○○ ○○○
AAA ○○○ ○○○ ○○○
BBB ○○○ ○○○ ○○○
BBB ○○○ ○○○ ○○○
CCC ○○○ ○○○ ○○○
CCC ○○○ ○○○ ○○○
DDD ○○○ ○○○ ○○○
DDD ○○○ ○○○ ○○○
DDD ○○○ ○○○ ○○○
以下略

回答No.1

kkkkkm · ベストアンサー

データは2行目からあり、品番が一塊として並んでいることを前提にしていますので、コードで品番をもとに並び替えしてから操作しています。
シートは品番名で新しく作るようにしています。
データは一行ずつではなく品番ごとに一塊で新しいシートに代入しています。
一覧表はSheet1と考えてますので実際のシート名に変更してください。

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
With Sh1.Sort
With .SortFields
.Clear
.Add Key:=Sh1.Range("A2"), SortOn:=xlSortOnValues
End With
.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "D"))
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With
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.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(c.Row - fRow + 1, 4).Value = Sh1.Range(Sh1.Cells(fRow, "A"), Sh1.Cells(c.Row, "D")).Value
Set Sh2 = Nothing
fRow = c.Offset(1, 0).Row
End If
Next
Sh1.Activate
Application.ScreenUpdating = True
Set Sh1 = Nothing
End Sub

お礼

一連のVBA3パートが完成しました。仕事で活用させて頂くのですが、月に3時間分効率化出来る見込みです。コードを読みといて、次の効率化の切り口にしたいと思います。有り難う御座いました。

回答No.4

kkkkkm

> Sheet1(一覧表)はソートの必要がない為、下記部分を割愛しましたが
正しいでしょうか。

はい、それでお願いします。

回答No.3

imogasi

いつもの小生の処理パターンですが、
例データ　Sheet1のA1:C11
内訳 1 内訳 2 合計
AAA ○○○ ○○○
AAA ○○○ ○○○
BBB ○○○ ○○○
BBB ○○○ ○○○
BBB ○○○ ○○○
CCC ○○○ ○○○
CCC ○○○ ○○○
DDD ○○○ ○○○
DDD ○○○ ○○○
DDD ○○○ ○○○
ーー
標準モジュールに
Sub test02()
Dim i, j, k As Long
Set sh1 = Worksheets("Sheet1") '原本シート
lr = sh1.Range("A100000").End(xlUp).Row
MsgBox lr
mae = sh1.Cells(2, "A")
sh = 2
'--見出し
k = 1
j = 1
GoSub meisai
For i = 2 To lr
If sh1.Cells(i, "A") = mae Then
'--内訳けコード変わらず
'明細
' kは引き継ぎ
j = i
GoSub meisai
Else
'内訳けコード変わった
sh = sh + 1 '次のシートを指す
'--見出し
k = 1
j = 1
GoSub meisai
'--明細
' kは引き継ぎ
j = i
GoSub meisai
End If
mae = sh1.Cells(i, "A")
Next i
'---
Exit Sub
'－－－
meisai:
Sheets(sh).Cells(k, "A") = sh1.Cells(j, "A")
Sheets(sh).Cells(k, "B") = sh1.Cells(j, "B")
Sheets(sh).Cells(k, "C") = sh1.Cells(j, "C")
k = k + 1
Return
End Sub
ーーー
結果
Sheet2からShhet5に結果データが出る。１例を参考に
Sheet5
内訳 1 内訳 2 合計
DDD ○○○ ○○○
DDD ○○○ ○○○
DDD ○○○ ○○○
ーー
前提
Sheet1のA列でソート済みとする。
Sheet2からSheet5までなどのシート数は当初出来上がっていると仮定。
Sheet1のA列のコードのユニークな数＋１がシート必要数だがこのチェックや
ユニークな数の出し方は省略。
元データに、D列以後がある場合は、上記meisaiサブルーチンなどの最後に、コード行を加えてください。
基データが１０万行以上あれば要修正。
Sheet2からSheet5の間は、他のシートは、ないことが前提。

お礼

imogasi 様

ご教示有難うございました。
サンプルデータにて検証・勉強させて頂きます。

回答No.2

kkkkkm

No1で1行目の見出しを忘れてました。
Set Sh2 = Sheets(c.Value)
のあとに
Sh2.Range("A1:D1").Value = Sh1.Range("A1:D1").Value
を足してください。

補足

kkkkkm 様

ご教示有難うございました。
Sheet1(一覧表)はソートの必要がない為、下記部分を割愛しましたが
正しいでしょうか。サンプルデータでの動作は正常な結果となりました。

'With Sh1.Sort
'With .SortFields
'.Clear
'.Add Key:=Sh1.Range("A2"), SortOn:=xlSortOnValues
'End With
'.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "D"))
'.Header = xlNo
'.Orientation = xlTopToBottom
'.Apply
'End With