質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

コピー

元のオブジェクトを破壊することなく、オブジェクトの複製を生成することをコピーと呼びます。

Q&A

解決済

4回答

1416閲覧

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

Highlight5

総合スコア1

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

コピー

元のオブジェクトを破壊することなく、オブジェクトの複製を生成することをコピーと呼びます。

0グッド

0クリップ

投稿2020/07/27 14:52

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

番号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行空白までを順番にコピーするという形でと考えたのですが、そもそもこのやり方でいいのか?もっと一回でできる方法はございますでしょうか? 大変申し訳ございませんが、教えて頂けませんでしょうか?

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

meg_

2020/07/27 22:09

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

回答4

0

ベストアンサー

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

ExcelVBA

1Sub test() 2 Dim Rng As Range 3 Dim a As Range 4 Dim i As Long 5 Dim ix As Long 6 Dim sName As String 7 Dim wshNew As Worksheet 8 Const n As Long = 4 9 10 Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlCount, TotalList:=4 11 With Range("A1").CurrentRegion 12 Set Rng = Intersect(.Cells, .Offset(1)) 13 End With 14 15 For Each a In Rng.Columns(4).SpecialCells(xlCellTypeConstants).Areas 16 ix = 1 17 For i = 1 To a.Rows.Count Step n 18 sName = a.Cells(1).Value 19 Worksheets.Add after:=Worksheets(Worksheets.Count) 20 Set wshNew = Worksheets(Worksheets.Count) 21 Union(Rng.Rows(0), _ 22 Intersect(a.EntireRow, _ 23 a.Cells(i).Resize(n).EntireRow, _ 24 Rng)).Copy wshNew.Range("A1") 25 On Error GoTo ErrHandler 26 wshNew.Name = sName 27 On Error GoTo 0 28 Next 29 Next 30 31 Rng.RemoveSubtotal 32 Exit Sub 33 34ErrHandler: 35 ix = ix + 1 36 sName = Split(sName, "(")(0) & "(" & ix & ")" 37 Resume 38End Sub

投稿2020/07/29 08:20

mattuwan

総合スコア2136

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

Highlight5

2020/07/29 15:51

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

2020/08/16 12:57

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

0

削除しておきました。

投稿2020/07/28 23:03

編集2020/07/28 23:33
mako1972

総合スコア383

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

0

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

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

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

VBA

1Sub test() 2 3Dim celno As Double 4Dim num As Double 5 6celno = 1 7 8For i = 2 To 15 9 10With Sheets("data") 11 12 納入場所 = .Range("D" & i).Value 13 14 celno = celno + 1 15 16 If 納入場所 <> 前回納入場所 Then 17 18 num = 0 19 20 If i = 2 Then 21 Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value 22 Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value 23 Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value 24 Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value 25 26 ElseIf i <> 2 Then 27 celno = celno + 1 28 29 Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value 30 Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value 31 Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value 32 Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value 33 34 End If 35 36 End If 37 38 39 If 納入場所 = 前回納入場所 Then 40 41 num = num + 1 42 43 If num = 4 Then 44 45 celno = celno + 1 46 47 Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value 48 Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value 49 Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value 50 Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value 51 52 num = 0 53 54 Else 55 Sheets("tenki").Range("A" & celno).Value = .Range("A" & i).Value 56 Sheets("tenki").Range("B" & celno).Value = .Range("B" & i).Value 57 Sheets("tenki").Range("C" & celno).Value = .Range("C" & i).Value 58 Sheets("tenki").Range("D" & celno).Value = .Range("D" & i).Value 59 60 End If 61 62 End If 63 64 65 66 前回納入場所 = 納入場所 67 68End With 69 70Next 71 72End Sub

投稿2020/07/28 00:32

編集2020/07/29 08:27
mako1972

総合スコア383

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

Highlight5

2020/07/29 15:44

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

0

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

VBA

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

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

VBA

1Sub Test_Sample_Miniature() 2 Dim MyRange As Range 3 Dim StaCell As Range 4 Dim EndCell As Range 5 Dim BefCell As Range 6 Dim intCount As Integer 7 Dim intMax As Integer 8 Set StaCell = Range("A1") 9 Set EndCell = Range("D1") 10 Set BefCell = Range("D1") 11 intCount = 0 12 intMax = 0 13 For Each MyRange In Range("D1:D16") 14 If MyRange.Value <> BefCell.Value Or intMax = 4 Then 15 Set EndCell = BefCell 16 intMax = 0 17 With Worksheets("Sheet1").Range(StaCell, EndCell) 18 Select Case intCount 19 Case 0 20 .Copy Destination:=Worksheets("Sheet2").Range("A1") 21 Case 1 22 .Copy Destination:=Worksheets("Sheet2").Range("A2") 23 Case 2 24 .Copy Destination:=Worksheets("Sheet2").Range("A7") 25 Case 3 26 .Copy Destination:=Worksheets("Sheet2").Range("A9") 27 Case 4 28 .Copy Destination:=Worksheets("Sheet2").Range("A13") 29 Case 5 30 .Copy Destination:=Worksheets("Sheet2").Range("A18") 31 End Select 32 End With 33 intCount = intCount + 1 34 Set StaCell = Cells(MyRange.Row, 1) 35 End If 36 Set BefCell = MyRange 37 intMax = intMax + 1 38 Next 39End Sub

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

VBA

1Sub Test_Sample_Miniature() 2 Dim MyRange As Range 3 Dim CopyRange As Range 4 Dim lngToRow As Long 5 Dim StaCell As Range 6 Dim EndCell As Range 7 Dim BefCell As Range 8 Dim intMax As Integer 9 Set StaCell = Range("A1") 10 Set EndCell = Range("D1") 11 Set BefCell = Range("D1") 12 lngToRow = 1 13 intMax = 0 14 For Each MyRange In Range("D1:D16") 15 If MyRange.Value <> BefCell.Value Or intMax = 4 Then 16 Set EndCell = BefCell 17 intMax = 0 18 Set CopyRange = Worksheets("Sheet1").Range(StaCell, EndCell) 19 CopyRange.Copy Destination:=Worksheets("Sheet2").Cells(lngToRow, 1) 20 lngToRow = lngToRow + CopyRange.Rows.Count + 1 21 intCount = intCount + 1 22 Set StaCell = Cells(MyRange.Row, 1) 23 End If 24 Set BefCell = MyRange 25 intMax = intMax + 1 26 Next 27End Sub

投稿2020/07/27 23:31

編集2020/07/28 19:52
tosi

総合スコア553

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

Highlight5

2020/07/29 15:55

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問