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

Question

シート１のデータはそのままで、
シート２に編集して転記したいです。
シート１には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日頑張ってうまくできず
上手く説明できません。
よろしくお願いします。

tom04 · Accepted Answer

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

tom04 · Answer

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

jcctaira · Answer

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

tom04 · Answer

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

（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

KURUMITO · Answer

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

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

No.2・4です。

No.2です！

gx9wxさん

この回答への補足

こんにちは！

この回答への補足

マクロでなくても関数のみでも解決できますがマクロでなくてはいけないのでしょうか？

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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