VBAについて(同じ値でかつ4件までをコピーする方法)

Question

初心者です。
納入場所毎で、かつ最大４件まで事毎に、別シートにコピーしたいのですが
どういう風にすればよいか教えて頂きたいのです。
納入場所でソートしています。

番号1～4、5、6～8、9～12、13～14がそれぞれ一塊になるようにです。

番号 商品 数量 納入場所
1 りんご 10 大阪支店
2 みかん 5 大阪支店
3 桃 3 大阪支店
4 バナナ 8 大阪支店
5 梨 2 大阪支店
6 苺 3 名古屋支店
7 みかん 2 名古屋支店
8 桃 5 名古屋支店
9 りんご 10 東京本社
10 苺 8 東京本社
11 バナナ 5 東京本社
12 すいか 4 東京本社
13 パイナップル 6 東京本社
14 桃 2 東京本社

下記のようそれぞれを別のｼｰﾄに分けたいのです。

番号 商品 数量 納入場所
1 りんご 10 大阪支店
2 みかん 5 大阪支店
3 桃 3 大阪支店
4 バナナ 8 大阪支店

5 梨 2 大阪支店

6 苺 3 名古屋支店
7 みかん 2 名古屋支店
8 桃 5 名古屋支店

9 りんご 10 東京本社
10 苺 8 東京本社
11 バナナ 5 東京本社
12 すいか 4 東京本社

13 パイナップル 6 東京本社
14 桃 2 東京本社

### 試したこと
1納入場所をKEYにて、前後値が異なったら、1行挿入しました
2そこから納入場所が5件以上になったら、1行挿入しようと考えています。
2が出来ていません。
3その後、上から順に1行空白までを順番にコピーするという形でと考えたのですが、そもそもこのやり方でいいのか？もっと一回でできる方法はございますでしょうか？
大変申し訳ございませんが、教えて頂けませんでしょうか？

Comments

[meg_]

コードを提示してください。

Answer 1

小計機能(Subtotalメソッド)を使うと、キーブレークしている個所に小計行が自動で入りますので、
「空白行を挿入」の変わりができます。
で、4列目にデータの個数でも仮で個数をカウントしておけば、
自動で「数式」が入りますので、
4列目をジャンプ機能(SpecialCells)で「定数」を指定したら、各支社のセル範囲が取得できます。
その取得できた飛び飛びのセル範囲のArersコレクションをループしながら、
新しいシートに転記していくといいと思います。

Sub test()
    Dim Rng As Range
    Dim a As Range
    Dim i As Long
    Dim ix As Long
    Dim sName As String
    Dim wshNew As Worksheet
    Const n As Long = 4
    
    Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlCount, TotalList:=4
    With Range("A1").CurrentRegion
        Set Rng = Intersect(.Cells, .Offset(1))
    End With

    For Each a In Rng.Columns(4).SpecialCells(xlCellTypeConstants).Areas
        ix = 1
        For i = 1 To a.Rows.Count Step n
            sName = a.Cells(1).Value
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Set wshNew = Worksheets(Worksheets.Count)
            Union(Rng.Rows(0), _
                  Intersect(a.EntireRow, _
                            a.Cells(i).Resize(n).EntireRow, _
                            Rng)).Copy wshNew.Range("A1")
            On Error GoTo ErrHandler
            wshNew.Name = sName
            On Error GoTo 0
        Next
    Next
    
    Rng.RemoveSubtotal
    Exit Sub
    
ErrHandler:
    ix = ix + 1
    sName = Split(sName, "(")(0) & "(" & ix & ")"
    Resume
End Sub

Comments

[Highlight5]

教えて頂き、有難うございます。
やってみます。
貴重なお時間をすみませんでした。

[Highlight5]

自分自身のレベルが低すぎて、時間がかかってしまいすみません。
これを使わせて頂いて、進めて行っております。
お忙しい中、お手数をお掛けしてしまい、申し訳ございませんでした

Answer 2

削除しておきました。

Answer 3

コメント無駄なので削除します。

私にはいいのですが、コードを
試したのかどうか、コメントはした方がよろしいかと思います（皆さん必死に考えてくれていますので）。

dataシートを評価して、tenkiシートに展開するサンプルです。
参考にならないと思いますが掲載しておきます。

Sub test()

Dim celno As Double
Dim num As Double

celno = 1

For i = 2 To 15

With Sheets("data")
    
    納入場所 = .Range("D" & i).Value
    
    celno = celno + 1
    
            If 納入場所 <> 前回納入場所 Then
            
             num = 0
            
             If i = 2 Then
                Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value
                Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value
                Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value
                Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value
            
            ElseIf i <> 2 Then
             celno = celno + 1
             
                Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value
                Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value
                Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value
                Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value
   
            End If
    
    End If

    
    If 納入場所 = 前回納入場所 Then
    
         num = num + 1
         
         If num = 4 Then
                
                celno = celno + 1
                
                Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value
                Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value
                Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value
                Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value
                
                num = 0
                
         Else
                Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value
                Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value
                Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value
                Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value
         
         End If

    End If



    前回納入場所 = 納入場所
    
End With

Next

End Sub

Comments

[Highlight5]

貴重なお時間を割いて頂き、ご回答頂きましたのに、失礼いたしました。
教えて頂いたことをコードで書いていかないといけないと思って、調べておりました。
大変申し訳ございませんでした。有難うございました。

Answer 4

複写元Sheet1、複写先Sheet2。(単純複写)

'(Test_Sample_Miniature)
Worksheets("Sheet1").Range("A1:D5").Copy Destination:=Worksheets("Sheet2").Range("A1")
Worksheets("Sheet1").Range("A6:D6").Copy Destination:=Worksheets("Sheet2").Range("A7")
Worksheets("Sheet1").Range("A7:D9").Copy Destination:=Worksheets("Sheet2").Range("A9")
Worksheets("Sheet1").Range("A10:D13").Copy Destination:=Worksheets("Sheet2").Range("A13")
Worksheets("Sheet1").Range("A13:D15").Copy Destination:=Worksheets("Sheet2").Range("A18")

質問内容良く読んでいませんでした。追記します。

Sub Test_Sample_Miniature()
    Dim MyRange As Range
    Dim StaCell As Range
    Dim EndCell As Range
    Dim BefCell As Range
    Dim intCount As Integer
    Dim intMax As Integer
    Set StaCell = Range("A1")
    Set EndCell = Range("D1")
    Set BefCell = Range("D1")
    intCount = 0
    intMax = 0
    For Each MyRange In Range("D1:D16")
        If MyRange.Value <> BefCell.Value Or intMax = 4 Then
            Set EndCell = BefCell
            intMax = 0
            With Worksheets("Sheet1").Range(StaCell, EndCell)
                Select Case intCount
                    Case 0
                        .Copy Destination:=Worksheets("Sheet2").Range("A1")
                    Case 1
                        .Copy Destination:=Worksheets("Sheet2").Range("A2")
                    Case 2
                        .Copy Destination:=Worksheets("Sheet2").Range("A7")
                    Case 3
                        .Copy Destination:=Worksheets("Sheet2").Range("A9")
                    Case 4
                        .Copy Destination:=Worksheets("Sheet2").Range("A13")
                    Case 5
                        .Copy Destination:=Worksheets("Sheet2").Range("A18")
                End Select
            End With
            intCount = intCount + 1
            Set StaCell = Cells(MyRange.Row, 1)
        End If
        Set BefCell = MyRange
        intMax = intMax + 1
    Next
End Sub

省略型思いつきました。追記致します。

Sub Test_Sample_Miniature()
    Dim MyRange As Range
    Dim CopyRange As Range
    Dim lngToRow As Long
    Dim StaCell As Range
    Dim EndCell As Range
    Dim BefCell As Range
    Dim intMax As Integer
    Set StaCell = Range("A1")
    Set EndCell = Range("D1")
    Set BefCell = Range("D1")
    lngToRow = 1
    intMax = 0
    For Each MyRange In Range("D1:D16")
        If MyRange.Value <> BefCell.Value Or intMax = 4 Then
            Set EndCell = BefCell
            intMax = 0
            Set CopyRange = Worksheets("Sheet1").Range(StaCell, EndCell)
            CopyRange.Copy Destination:=Worksheets("Sheet2").Cells(lngToRow, 1)
            lngToRow = lngToRow + CopyRange.Rows.Count + 1
            intCount = intCount + 1
            Set StaCell = Cells(MyRange.Row, 1)
        End If
        Set BefCell = MyRange
        intMax = intMax + 1
    Next
End Sub

Comments

[Highlight5]

何度も教えて頂き、有難うございます。
貴重なお時間を割いて頂き、すみませんでした。
なかなかコードに慣れていないので、すぐに出来ませんが、試してやってみます。