シート1のデータはそのままで、
シート2に編集して転記したいです。
シート1にはA列からI列までデータが入っています。
行数は都度変わりますがデータは3行目から始まり
大体500行くらいです。
転記方法は
シート1のD列→シート2のA列
シート1のE列→シート2のB列
シート1のF列→シート2のC列
シート1のC列→シート2のD列
でシート1のD列の値が同じ場合は
転記先のシート2の行数は増やさずにシート1のC列の値を
同じ値のF列内にカンマでつないで転記したいです。
でそのつないだ合計数をシート2のE列に表示したいです。
イメージ
C D E F
------------------------
A1 みかん 国内 Sサイズ
A3 みかん 国内 Sサイズ
D6 みかん 国内 Sサイズ
D9 りんご 国内 Mサイズ
G7 りんご 国内 Mサイズ
F5 バナナ 海外 Lサイズ
G1 バナナ 海外 Lサイズ
A2 いちご 国内 Sサイズ
D8 いちご 国内 Sサイズ
F3 いちご 国内 Sサイズ
H2 いちご 国内 Sサイズ
↓
A B C D E
-------------------------------------------
みかん 国内 Sサイズ A1,A3,D6 3←3個
りんご 国内 Mサイズ D9,G7 2←2個
バナナ 海外 Lサイズ F5,G1 2←2個
いちご 国内 Sサイズ A2,D8,F3,H2 4←4個
上記例の場合は元データは11行ですが編集後は4行です。
配列は自力で作成できないので考え方を教えていただきたいです。
構文をそのまま書いていただいても大変助かります。
Do~LoopかFor~Nextで上から順最終行まで処理で
シート1からシート2へ転記する構文をかいて
D列の値が直前に処理した値と同じ場合は
転記はしないでC列の値を変数1に代入し
シート2の該当行のD列も変数2に代入し
変数1&","&変数2で対象行のD列に転記と考えましたが
うまくできませんでした。
またシート2のE列の求め方ですが、上記変数1,2に代入した後に
変数3=変数3+1とかの文でカウントし、
その値を転記すればいいのでしょうか?
すいません。今日1日頑張ってうまくできず
上手く説明できません。
よろしくお願いします。
No.5ベストアンサー
- 回答日時:
No.2・4です。
>Sheet1のD列に途中空白があるのが
>わかり苦戦しています・・・
とありますが、最初の質問ではその件がなかったので、当然今までのコードではご希望の動作はしないと思います。
空白なのは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
- 回答日時:
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
- 回答日時:
gx9wxさん
こんにちは。
> 同じ値のF列内にカンマでつないで転記したいです。
F列内ではなくD列としました。
以下のマクロで可能かと思います。
※シート2のタイトルは設定していません。また3行目から転記しています。
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のD列に途中空白があるのが
わかり苦戦しています。
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
- 回答日時:
こんにちは!
色々考え方はあるかと思いますが・・・
一例です。
(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のD列に途中空白があるのが
わかり苦戦しています。
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
- 回答日時:
マクロでなくても関数のみでも解決できますがマクロでなくてはいけないのでしょうか?
みかんでも国内、国外、Sサイズ、Lサイズなどいろいろあると思うのですが、ミカンの行は1行でということなのでしょうか?
この回答への補足
ありがとうございます。
一応自力で作成した物です。
Sheet1のD列に途中空白があるのが
わかり苦戦しています。
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
申し訳ありません。
マクロを起動をすると、15種類くらいの処理を
してここにたどり着きます。
最後にこの処理を行い自動保存して終了です。
この処理もマクロで行いたいと思っています。
説明不足ですいません。
D列の値が同じ場合はE,F列も同じ値でG列のみ相違となります。
D列がみかんならE列は必ず国内、F列はSサイズです。
(実際にはもっと長い文字列なのですが例なので上記のように書きました。)
よろしくお願いします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) VBAで、1つのエクセルで、2つのシートからもう1つのシートに条件のある転記コードを教えてください。 1 2023/03/16 18:07
- Visual Basic(VBA) VBAで、シート間の転記するコードをFOR~NEXTで教えてください。 9 2023/04/30 20:04
- Excel(エクセル) Excelで、別シートの表のステータスに伴った動的な自動転記をしたいです。 2 2023/06/14 15:56
- Visual Basic(VBA) コード名シートA列と集計シートA列のコードが一致したら、コード名シートA5からk12の範囲をコピーし 1 2022/08/29 23:46
- Visual Basic(VBA) まとめシートから集計シートへA列のコードが一致したら1行コピーするマクロをネット上で見つけました。こ 1 2022/08/30 14:11
- Visual Basic(VBA) 別シートのデータを参照して値を入れたい。 まとめデータシートのC列D列の値を商品一覧シートのコードが 7 2022/08/17 13:20
- Excel(エクセル) Excel_マクロ_複数のシートのVLOOKUPで表示された#N/A以外に色付けをしたいです 1 2023/02/16 22:37
- Excel(エクセル) 別シートに毎回異なるデータをコピーする 7 2022/06/24 09:02
- その他(Microsoft Office) エクセルマクロ オートフィルターでで選択コピー 2 2022/04/18 11:05
- Visual Basic(VBA) VBA 最終行まで数式をコピーする 3 2023/01/03 15:44
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
セックスする度に胸が大きくな...
-
週1ペースで会うカップルでデー...
-
母子相姦経験者ですが、日本で...
-
恋人とセフレの違いはなんです...
-
おじさんになってから若い女性に
-
彼氏が私の性格も見た目も褒め...
-
セックスの2回目が無理
-
セックスについて。 彼が正常位...
-
彼女が噛んできます。 歯型がつ...
-
初めて泊まりにきてくれる彼女...
-
セックス前にAV
-
セックスする時なぜ声出るの
-
セックスしたら彼氏のことが好...
-
30代前半男性の性欲
-
付き合って1ヶ月でヤった後別れ...
-
セフレや遊びでスローセックス...
-
一番多くて週に何回セックスし...
-
週1ペースで彼女と会っている社...
-
昨日久々に元セフレ(元々頻繁...
-
未成年同士でラブホに行った際...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
セックスする度に胸が大きくな...
-
週1ペースで会うカップルでデー...
-
恋人とセフレの違いはなんです...
-
セックスについて。 彼が正常位...
-
初めて泊まりにきてくれる彼女...
-
おじさんになってから若い女性に
-
30代前半男性の性欲
-
彼女が噛んできます。 歯型がつ...
-
彼女とのセックスに新鮮味を感...
-
セックス前にAV
-
彼氏が私の性格も見た目も褒め...
-
セックスの2回目が無理
-
付き合って1ヶ月でヤった後別れ...
-
僕の心が狭いのでしょうか…?セ...
-
オナ禁中はセックスしてもいい...
-
セックスする時って会話します...
-
一番多くて週に何回セックスし...
-
性欲と、人を好きになるって別...
-
俗にいうセフレの定義を知りた...
-
やりもくなのか本当に付き合い...
おすすめ情報