エクセルVBA シート１からシート２へ転記したい

質問

シート１のデータはそのままで、
シート２に編集して転記したいです。
シート１にはA列からI列までデータが入っています。
行数は都度変わりますがデータは3行目から始まり
大体５００行くらいです。
転記方法は
シート１のＤ列→シート２のＡ列
シート１のＥ列→シート２のＢ列
シート１のＦ列→シート２のＣ列
シート１のＣ列→シート２のＤ列

でシート１のＤ列の値が同じ場合は
転記先のシート２の行数は増やさずにシート１のＣ列の値を
同じ値のＦ列内にカンマでつないで転記したいです。
でそのつないだ合計数をシート２のＥ列に表示したいです。

イメージ

Ｃ　　Ｄ　　　　Ｅ　　　　　Ｆ
------------------------
A1　みかん　国内　Ｓサイズ
A3　みかん　国内　Ｓサイズ
D6　みかん　国内　Ｓサイズ
D9　りんご　国内　Ｍサイズ
G7　りんご　国内　Ｍサイズ
F5　バナナ　海外　Ｌサイズ
G1　バナナ　海外　Ｌサイズ
A2　いちご　国内　Ｓサイズ
D8　いちご　国内　Ｓサイズ
F3　いちご　国内　Ｓサイズ
H2　いちご　国内　Ｓサイズ

↓
Ａ　　　　Ｂ　　　　Ｃ　　　　　　Ｄ　　　　　Ｅ
-------------------------------------------
みかん　国内　Ｓサイズ　A1,A3,D6　　　３←3個
りんご　国内　Ｍサイズ　D9,G7　　 　　２←2個
バナナ　海外　Ｌサイズ　F5,G1　　 　　２←2個
いちご　国内　Ｓサイズ　A2,D8,F3,H2 　４←4個

上記例の場合は元データは１１行ですが編集後は４行です。

配列は自力で作成できないので考え方を教えていただきたいです。
構文をそのまま書いていただいても大変助かります。

Do～LoopかFor～Nextで上から順最終行まで処理で
シート１からシート２へ転記する構文をかいて
Ｄ列の値が直前に処理した値と同じ場合は
転記はしないでＣ列の値を変数1に代入し
シート２の該当行のＤ列も変数2に代入し
変数1&","&変数2で対象行のＤ列に転記と考えましたが
うまくできませんでした。
またシート２のＥ列の求め方ですが、上記変数1,2に代入した後に
変数3=変数3+１とかの文でカウントし、
その値を転記すればいいのでしょうか？
すいません。今日1日頑張ってうまくできず
上手く説明できません。
よろしくお願いします。

回答No.5

tom04 · ベストアンサー

No.2・4です。

＞Sheet1のＤ列に途中空白があるのが
＞わかり苦戦しています・・・

とありますが、最初の質問ではその件がなかったので、当然今までのコードではご希望の動作はしないと思います。

空白なのはD列だけですかね？
仮に行すべてが空白の場合はNo.4のコードでも大丈夫だと思いますが、↓の画像のような感じの場合は
D列に一つ上のセルデータを表示させれば大丈夫だと思います。

もう一度コードを載せておきます。

Sub test3()
Dim i, j, k As Long
Dim str As String
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 3 To ws1.Cells(Rows.Count, 3).End(xlUp).Row
If ws1.Cells(i, 4) = "" Then
ws1.Cells(i, 4) = ws1.Cells(i - 1, 4)
End If
Next i
ws2.Cells.Clear
With ws2.Cells(1, 1)
.Value = "品物"
.Offset(, 1) = "生産国"
.Offset(, 2) = "サイズ"
.Offset(, 4) = "個数"
End With
For i = 3 To ws1.Cells(Rows.Count, 3).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, 4)) = 0 Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 4)
.Offset(, 1) = ws1.Cells(i, 5)
.Offset(, 2) = ws1.Cells(i, 6)
End With
End If
Next i
For j = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To ws1.Cells(Rows.Count, 3).End(xlUp).Row
If ws1.Cells(i, 4) = ws2.Cells(j, 1) Then
str = str & ws1.Cells(i, 3) & ","
k = k + 1
End If
Next i
With ws2.Cells(j, 4)
.Value = Left(str, Len(str) - 1)
.Offset(, 1) = k
End With
str = ""
k = 0
Next j
ws2.Columns("A:E").AutoFit
End Sub

こんなんではどうでしょか？

※　具体的なデータ配置が判ればもっと詳細なコードが提示できると思います。m(__)m

お礼

いろいろすいません。
質問した内容とデータがかなり異なる為、
空白には設定した文字を転記して
その文字を使って除外したり、
そのA列の値をそのまま転記するなど
またループを回避するなどして
解決しました。
ありがとうございました。

回答No.4

tom04

No.2です！
たびたぼごめんなさい。

前回のコードはSheet1の列が1列ずれていました。
Sheet1のデータはC列の3行目からあるのですよね？

No.2は無視して、↓のコードにしてください。

Sub test2()
Dim i, j, k As Long
Dim str As String
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Cells.Clear
With ws2.Cells(1, 1)
.Value = "品物"
.Offset(, 1) = "生産国"
.Offset(, 2) = "サイズ"
.Offset(, 4) = "個数"
'Sheet1の項目名はこちらで勝手に入れています。
'尚、Sheet1のD列の項目名が不明ですので、Sheet2のD1セルは空白にしています。
End With
For i = 3 To ws1.Cells(Rows.Count, 3).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, 4)) = 0 Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 4)
.Offset(, 1) = ws1.Cells(i, 5)
.Offset(, 2) = ws1.Cells(i, 6)
End With
End If
Next i
For j = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To ws1.Cells(Rows.Count, 3).End(xlUp).Row
If ws1.Cells(i, 4) = ws2.Cells(j, 1) Then
str = str & ws1.Cells(i, 3) & ","
k = k + 1
End If
Next i
With ws2.Cells(j, 4)
.Value = Left(str, Len(str) - 1)
.Offset(, 1) = k
End With
str = ""
k = 0
Next j
ws2.Columns("A:E").AutoFit
End Sub

何度も失礼しました。m(__)m

お礼

お礼が遅れて申し訳有りません。
ありがとうございました。

回答No.3

jcctaira

gx9wxさん
こんにちは。

> 同じ値のＦ列内にカンマでつないで転記したいです。
Ｆ列内ではなくＤ列としました。

以下のマクロで可能かと思います。
※シート２のタイトルは設定していません。また３行目から転記しています。

Sub 集計()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim 分割　　As Variant
　Dim 個数　　As Variant
　Dim r　　　 As Long
　Sheets("Sheet1").Select
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　For r = 3 To Cells(Rows.Count, "D").End(xlUp).Row
　　　Key = Cells(r, "D")
　　　If .Exists(Key) = True Then
　　　　.Item(Key) = .Item(Key) & "," & Cells(r, "C")
　　　Else
　　　　.Add Key, Cells(r, "E") & "::" & Cells(r, "F") & "::" & Cells(r, "C")
　　　End If
　　Next r
　　r = 3
　　Sheets("Sheet2").Select
　　For Each Key In .keys
　　　分割 = Split(.Item(Key), "::")
　　　個数 = Split(分割(2), ",")
　　　Cells(r, "A") = Key
　　　Cells(r, "B") = 分割(0)
　　　Cells(r, "C") = 分割(1)
　　　Cells(r, "D") = 分割(2)
　　　Cells(r, "E") = UBound(個数) + 1
　　　r = r + 1
　　Next
　End With
　Cells.EntireColumn.AutoFit
　Set Dict = Nothing
End Sub

お礼

お礼が遅れて申し訳有りません。
ありがとうございました。

補足

ありがとうございます。
一応自力で作成した物です。
Sheet1のＤ列に途中空白があるのが
わかり苦戦しています。

Sub 転記2()
'2011年9月9日

Dim 処理行
Dim 転記先行
Dim 最終行
Dim 比較値
Dim 元番号
Dim 追加番号
Dim 回数
Dim 員数

Sheets("Sheet1").Select
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
転記先行 = 3
回数 = 1
For 処理行 = 3 To 最終行
比較行 = 処理行 - 1

比較値 = Cells(比較行, 4).Value
If Cells(処理行, 4).Value <> 比較値 Then
Sheets("Sheet2").Cells(転記先行, 1) = Sheets("Sheet1").Cells(処理行, 4)
Sheets("Sheet2").Cells(転記先行, 2) = Sheets("Sheet1").Cells(処理行, 5)
Sheets("Sheet2").Cells(転記先行, 3) = Sheets("Sheet1").Cells(処理行, 6)
Sheets("Sheet2").Cells(転記先行, 4) = Sheets("Sheet1").Cells(処理行, 3)
Sheets("Sheet2").Cells(転記先行, 5) = 1
転記先行 = 転記先行 + 1
回数 = 1
Else
回数 = 回数 + 1

転記先行 = 転記先行 - 1
元番号 = Cells(処理行, 3)
追加番号 = Sheets("Sheet2").Cells(転記先行, 4)
員数 = 追加番号 & "," & 元番号
Sheets("Sheet2").Cells(転記先行, 4).Value = 員数
Sheets("Sheet2").Cells(転記先行, 5) = 回数
転記先行 = 転記先行 + 1

End If
比較行 = 比較行 + 1

Next 処理行
End Sub

回答No.2

tom04

こんにちは！
色々考え方はあるかと思いますが・・・
一例です。

（1）Sheet2の1行目にSheet1の項目名を表示
（2）Sheet2のA～C列にSheet1のE列データを重複なしに表示
（3）Sheet2・Sheet1の各データをそれぞれFor～NextでLoopし、文字列は「&」で連結・個数は「+」で一つずつプラス。
（4）Sheet2のD列に連結した文字列の一文字少ないものを表示。E列に個数をプラスしたものを表示
（5）文字列・個数のデータをクリアにして次の行へ！
という考え方です。

Sub test()
Dim i, j, k As Long
Dim str As String
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
With ws2.Cells(1, 1)
.Value = "品物"
.Offset(, 1) = "生産国"
.Offset(, 2) = "サイズ"
.Offset(, 4) = "個数"
'Sheet1の項目名はこちらで勝手に入れています。
'尚、Sheet1のD列の項目名が不明ですので、Sheet2のD1セルは空白にしています。
End With
For i = 3 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, 5)) = 0 Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 5)
.Offset(, 1) = ws1.Cells(i, 6)
.Offset(, 2) = ws1.Cells(i, 7)
End With
End If
Next i
For j = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
If ws1.Cells(i, 5) = ws2.Cells(j, 1) Then
str = str & ws1.Cells(i, 4) & ","
k = k + 1
End If
Next i
With ws2.Cells(j, 4)
.Value = Left(str, Len(str) - 1)
.Offset(, 1) = k
End With
str = ""
k = 0
Next j
ws2.Columns("A:E").AutoFit
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

お礼が送れて申し訳有りません。
自己解決しました。
ありがとうございました。

補足

ありがとうございます。
一応自力で作成した物です。
Sheet1のＤ列に途中空白があるのが
わかり苦戦しています。

Sub 転記2()
'2011年9月9日

Dim 処理行
Dim 転記先行
Dim 最終行
Dim 比較値
Dim 元番号
Dim 追加番号
Dim 回数
Dim 員数

Sheets("Sheet1").Select
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
転記先行 = 3
回数 = 1
For 処理行 = 3 To 最終行
比較行 = 処理行 - 1

比較値 = Cells(比較行, 4).Value
If Cells(処理行, 4).Value <> 比較値 Then
Sheets("Sheet2").Cells(転記先行, 1) = Sheets("Sheet1").Cells(処理行, 4)
Sheets("Sheet2").Cells(転記先行, 2) = Sheets("Sheet1").Cells(処理行, 5)
Sheets("Sheet2").Cells(転記先行, 3) = Sheets("Sheet1").Cells(処理行, 6)
Sheets("Sheet2").Cells(転記先行, 4) = Sheets("Sheet1").Cells(処理行, 3)
Sheets("Sheet2").Cells(転記先行, 5) = 1
転記先行 = 転記先行 + 1
回数 = 1
Else
回数 = 回数 + 1

転記先行 = 転記先行 - 1
元番号 = Cells(処理行, 3)
追加番号 = Sheets("Sheet2").Cells(転記先行, 4)
員数 = 追加番号 & "," & 元番号
Sheets("Sheet2").Cells(転記先行, 4).Value = 員数
Sheets("Sheet2").Cells(転記先行, 5) = 回数
転記先行 = 転記先行 + 1

End If
比較行 = 比較行 + 1

Next 処理行
End Sub

回答No.1

KURUMITO

マクロでなくても関数のみでも解決できますがマクロでなくてはいけないのでしょうか？
みかんでも国内、国外、Sサイズ、Lサイズなどいろいろあると思うのですが、ミカンの行は1行でということなのでしょうか？

お礼

申し訳ありません。
マクロを起動をすると、１５種類くらいの処理を
してここにたどり着きます。
最後にこの処理を行い自動保存して終了です。
この処理もマクロで行いたいと思っています。
説明不足ですいません。
Ｄ列の値が同じ場合はＥ，Ｆ列も同じ値でＧ列のみ相違となります。
Ｄ列がみかんならＥ列は必ず国内、Ｆ列はＳサイズです。
（実際にはもっと長い文字列なのですが例なので上記のように書きました。）
よろしくお願いします。

補足

ありがとうございます。
一応自力で作成した物です。
Sheet1のＤ列に途中空白があるのが
わかり苦戦しています。

Sub 転記2()
'2011年9月9日

Dim 処理行
Dim 転記先行
Dim 最終行
Dim 比較値
Dim 元番号
Dim 追加番号
Dim 回数
Dim 員数

Sheets("Sheet1").Select
最終行 = Cells(Rows.Count, 1).End(xlUp).Row
転記先行 = 3
回数 = 1
For 処理行 = 3 To 最終行
比較行 = 処理行 - 1

比較値 = Cells(比較行, 4).Value
If Cells(処理行, 4).Value <> 比較値 Then
Sheets("Sheet2").Cells(転記先行, 1) = Sheets("Sheet1").Cells(処理行, 4)
Sheets("Sheet2").Cells(転記先行, 2) = Sheets("Sheet1").Cells(処理行, 5)
Sheets("Sheet2").Cells(転記先行, 3) = Sheets("Sheet1").Cells(処理行, 6)
Sheets("Sheet2").Cells(転記先行, 4) = Sheets("Sheet1").Cells(処理行, 3)
Sheets("Sheet2").Cells(転記先行, 5) = 1
転記先行 = 転記先行 + 1
回数 = 1
Else
回数 = 回数 + 1

転記先行 = 転記先行 - 1
元番号 = Cells(処理行, 3)
追加番号 = Sheets("Sheet2").Cells(転記先行, 4)
員数 = 追加番号 & "," & 元番号
Sheets("Sheet2").Cells(転記先行, 4).Value = 員数
Sheets("Sheet2").Cells(転記先行, 5) = 回数
転記先行 = 転記先行 + 1

End If
比較行 = 比較行 + 1

Next 処理行
End Sub