![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
エクセルvba初心者です。
以下のことを見様見真似でエクセルVBAのコード書こうとしたら上手くいきませんでした。
すみませんがコードを教えていただければと思います。
①エクセルシートにある値がD列とF列ともに同じである行のD列とF列のセルを赤い罫線で囲む。
②①の行のH列、I列、K列の値を列毎に足す。
③足した後の数値は、行を統合し、足した数値は赤で表示して、エクセルシートの下部に他のデータともに表示する。
行 列 A B C D E F G H I J K
3 1 2 51 20 5 100 88 3 2
4 1 2 100 15 5 102 99 3 1
5 1 2 51 20 3 103 100 3 8
6 1 2 100 15 5 99 36 5 4
↓
上記の表の場合、4行目のD列、F列 6行目のD列、F列が同じなので行を統合して4行目と6行目のH、I,K列のそれぞれの値の合計を出し、行を統合して、他のデータともにエクセルシートの下部に表示する。
行 列 A B C D E F G H I J K
3 1 2 51 20 5 100 88 3 2
4 1 2 100 15 5 201 135 3 5
5 1 2 51 20 3 103 100 3 8
※ 4行目のD列、F列のセルを赤い罫線で囲み、足した4行目のH、I,K列の数値を赤くする。
試しに私が書いたコードは上手くいきませんでした。
Sub Test1()
Dim r As Integer
Dim r2 As Integer
r = 2
Do While Cells(r, 4).Value <> ""
r2 = r + 1
Do While Cells(r2, 4).Value <> ""
If Cells(r, 4).Value = Cells(r2, 4).Value And Cells(r, 6).Value = Cells(r2, 6).Value Then
MsgBox "D列とF列に共通の数字があります。"
.Borders.LineStyle = True
Else
MsgBox "D列とF列に共通の数字はありません。"
r2 = r2 + 1
End If
Loop
r = r + 1
Loop
End Sub
よろしくお願いします。
![「2列同じ値がある場合その行を統合して下部」の質問画像](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/3/542933172_5dbae5852651d/M.jpg)
No.6ベストアンサー
- 回答日時:
回答ではありませんが、実際やってみると罫線や文字に色付けって割と判りにくいです。
薄い背景色を付ける方が区別が付き易いと思いますがいかがでしょうか?
Sub Sample2()
Const Lng_空き行数 As Long = 5
Const Lng_重複色 As Long = vbYellow
Dim Lng_最終行 As Long
Dim Lng_行差 As Long
Dim Lng_始行 As Long
Dim Lng_終行 As Long
Dim Lng_元行 As Long
Dim Lng_先行 As Long
Lng_最終行 = Range("D3").End(xlDown).Row
Lng_行差 = Lng_最終行 + Lng_空き行数 - 1
Lng_始行 = Lng_行差 + 3
' ↓ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(Lng_最終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
Range(Cells(3, 2), Cells(Lng_最終行, 11)).Interior.ColorIndex = xlNone
' ↑ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(2, 2), Cells(Lng_最終行, 11)).Copy Cells(Lng_始行 - 1, 2)
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
For Lng_元行 = Lng_始行 To Lng_終行
If Cells(Lng_元行, 4).Value <> "" Then
Cells(Lng_元行, 1).Value = Lng_元行
For Lng_先行 = Lng_元行 + 1 To Lng_終行
If Cells(Lng_元行, 4).Value = Cells(Lng_先行, 4).Value Then
If Cells(Lng_元行, 6).Value = Cells(Lng_先行, 6).Value Then
Cells(Lng_元行, 4).Interior.Color = Lng_重複色
Cells(Lng_元行, 6).Interior.Color = Lng_重複色
Cells(Lng_元行 - Lng_行差, 4).Interior.Color = Lng_重複色
Cells(Lng_元行 - Lng_行差, 6).Interior.Color = Lng_重複色
Cells(Lng_先行 - Lng_行差, 4).Interior.Color = Lng_重複色
Cells(Lng_先行 - Lng_行差, 6).Interior.Color = Lng_重複色
Cells(Lng_元行, 8).Value = Cells(Lng_元行, 8).Value + Cells(Lng_先行, 8).Value
Cells(Lng_元行, 9).Value = Cells(Lng_元行, 9).Value + Cells(Lng_先行, 9).Value
Cells(Lng_元行, 11).Value = Cells(Lng_元行, 11).Value + Cells(Lng_先行, 11).Value
Cells(Lng_元行, 8).Interior.Color = Lng_重複色
Cells(Lng_元行, 9).Interior.Color = Lng_重複色
Cells(Lng_元行, 11).Interior.Color = Lng_重複色
Rows(Lng_先行).ClearContents
End If
End If
Next
End If
Next
Range(Cells(Lng_始行, 1), Cells(Lng_終行, 11)).Sort _
Key1:=Cells(Lng_始行, 1), Order1:=xlAscending, Header:=xlNo
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
Range(Cells(Lng_終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
Columns(1).ClearContents
End Sub
No.5
- 回答日時:
No.4 の訂正です。
大変申し訳ございません。ソートしても罫線は移動しない事を忘れていました。以下の物と入れ替えて下さい。
Sub Sample()
Const Lng_空き行数 As Long = 5
Dim Lng_最終行 As Long
Dim Lng_行差 As Long
Dim Lng_始行 As Long
Dim Lng_終行 As Long
Dim Lng_元行 As Long
Dim Lng_先行 As Long
Lng_最終行 = Range("D3").End(xlDown).Row
Lng_行差 = Lng_最終行 + Lng_空き行数 - 1
Lng_始行 = Lng_行差 + 3
' ↓ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(Lng_最終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
With Range(Cells(3, 2), Cells(Lng_最終行, 11))
.Borders(xlEdgeLeft).ColorIndex = 0
.Borders(xlEdgeTop).ColorIndex = 0
.Borders(xlEdgeBottom).ColorIndex = 0
.Borders(xlEdgeRight).ColorIndex = 0
.Borders(xlInsideVertical).ColorIndex = 0
.Borders(xlInsideHorizontal).ColorIndex = 0
End With
' ↑ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(2, 2), Cells(Lng_最終行, 11)).Copy Cells(Lng_始行 - 1, 2)
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
For Lng_元行 = Lng_始行 To Lng_終行
If Cells(Lng_元行, 4).Value <> "" Then
Cells(Lng_元行, 1).Value = Lng_元行 * 10
For Lng_先行 = Lng_元行 + 1 To Lng_終行
If Cells(Lng_元行, 4).Value = Cells(Lng_先行, 4).Value Then
If Cells(Lng_元行, 6).Value = Cells(Lng_先行, 6).Value Then
Cells(Lng_元行, 1).Value = Lng_元行 * 10 + 5
Call 罫線色付(Lng_元行 - Lng_行差, 4)
Call 罫線色付(Lng_元行 - Lng_行差, 6)
Call 罫線色付(Lng_先行 - Lng_行差, 4)
Call 罫線色付(Lng_先行 - Lng_行差, 6)
Cells(Lng_元行, 8).Value = Cells(Lng_元行, 8).Value + Cells(Lng_先行, 8).Value
Cells(Lng_元行, 9).Value = Cells(Lng_元行, 9).Value + Cells(Lng_先行, 9).Value
Cells(Lng_元行, 11).Value = Cells(Lng_元行, 11).Value + Cells(Lng_先行, 11).Value
Cells(Lng_元行, 8).Font.Color = vbRed
Cells(Lng_元行, 9).Font.Color = vbRed
Cells(Lng_元行, 11).Font.Color = vbRed
Rows(Lng_先行).ClearContents
End If
End If
Next
End If
Next
Range(Cells(Lng_始行, 1), Cells(Lng_終行, 11)).Sort _
Key1:=Cells(Lng_始行, 1), Order1:=xlAscending, Header:=xlNo
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
Range(Cells(Lng_終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
For Lng_元行 = Lng_始行 To Lng_終行
If Cells(Lng_元行, 1).Value Mod 10 = 5 Then
Call 罫線色付(Lng_元行, 4)
Call 罫線色付(Lng_元行, 6)
End If
Next
Columns(1).ClearContents
End Sub
Sub 罫線色付(Lng_行番号 As Long, Lng_列番号 As Long, Optional Lng_色 As Long = vbRed)
With Cells(Lng_行番号, Lng_列番号)
.Borders(xlEdgeLeft).Color = Lng_色
.Borders(xlEdgeTop).Color = Lng_色
.Borders(xlEdgeBottom).Color = Lng_色
.Borders(xlEdgeRight).Color = Lng_色
End With
End Sub
※ A列の行番号に同じものが有るときは端数を付けてマークしておき、その端数が有る行を後で罫線に色付けしています。
※ 先ほどは説明が抜けていましたが「Sub 罫線色付」は呼び出す側で色の指定も可能です。何も指定しない場合は「赤」が指定されたことになっています。
No.4
- 回答日時:
30行位なら何をやってもそれほどスピードが変わらないので以下の様な物はいかがでしょうか?
Sub Sample()
Const Lng_空き行数 As Long = 5
Dim Lng_最終行 As Long
Dim Lng_行差 As Long
Dim Lng_始行 As Long
Dim Lng_終行 As Long
Dim Lng_元行 As Long
Dim Lng_先行 As Long
Lng_最終行 = Range("D3").End(xlDown).Row
Lng_行差 = Lng_最終行 + Lng_空き行数 - 1
Lng_始行 = Lng_行差 + 3
' ↓ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(Lng_最終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
With Range(Cells(3, 2), Cells(Lng_最終行, 11))
.Borders(xlEdgeLeft).ColorIndex = 0
.Borders(xlEdgeTop).ColorIndex = 0
.Borders(xlEdgeBottom).ColorIndex = 0
.Borders(xlEdgeRight).ColorIndex = 0
.Borders(xlInsideVertical).ColorIndex = 0
.Borders(xlInsideHorizontal).ColorIndex = 0
End With
' ↑ 前回の結果が残っていた時の念のための処理です。不要なら削除して下さい。
Range(Cells(2, 2), Cells(Lng_最終行, 11)).Copy Cells(Lng_始行 - 1, 2)
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
For Lng_元行 = Lng_始行 To Lng_終行
If Cells(Lng_元行, 4).Value <> "" Then
Cells(Lng_元行, 1).Value = Lng_元行
For Lng_先行 = Lng_元行 + 1 To Lng_終行
If Cells(Lng_元行, 4).Value = Cells(Lng_先行, 4).Value Then
If Cells(Lng_元行, 6).Value = Cells(Lng_先行, 6).Value Then
Call 罫線色付(Lng_元行, 4)
Call 罫線色付(Lng_元行, 6)
Call 罫線色付(Lng_元行 - Lng_行差, 4)
Call 罫線色付(Lng_元行 - Lng_行差, 6)
Call 罫線色付(Lng_先行 - Lng_行差, 4)
Call 罫線色付(Lng_先行 - Lng_行差, 6)
Cells(Lng_元行, 8).Value = Cells(Lng_元行, 8).Value + Cells(Lng_先行, 8).Value
Cells(Lng_元行, 9).Value = Cells(Lng_元行, 9).Value + Cells(Lng_先行, 9).Value
Cells(Lng_元行, 11).Value = Cells(Lng_元行, 11).Value + Cells(Lng_先行, 11).Value
Cells(Lng_元行, 8).Font.Color = vbRed
Cells(Lng_元行, 9).Font.Color = vbRed
Cells(Lng_元行, 11).Font.Color = vbRed
Rows(Lng_先行).ClearContents
End If
End If
Next
End If
Next
Range(Cells(Lng_始行, 1), Cells(Lng_終行, 11)).Sort _
Key1:=Cells(Lng_始行, 1), Order1:=xlAscending, Header:=xlNo
Lng_終行 = Cells(Lng_始行, 4).End(xlDown).Row
Range(Cells(Lng_終行 + 1, 1), Cells(Rows.Count, 11)).Delete Shift:=xlUp
Columns(1).ClearContents
End Sub
Sub 罫線色付(Lng_行番号 As Long, Lng_列番号 As Long, Optional Lng_色 As Long = vbRed)
With Cells(Lng_行番号, Lng_列番号)
.Borders(xlEdgeLeft).Color = Lng_色
.Borders(xlEdgeTop).Color = Lng_色
.Borders(xlEdgeBottom).Color = Lng_色
.Borders(xlEdgeRight).Color = Lng_色
End With
End Sub
☆ 動作説明
① まず全体のコピーを作成します。
② 後でソート用に使う行番号をA列にセットしながら順に比べていって同じなら指定された作業をし、比較された行はクリアします。
③ A列でソートしてクリアされた行を下に持っていきます。
④ 不要になったクリアされた行をまとめて削除し、不要になったA列をクリアしています。
※ 途中、行削除ではなくクリアしているのは行がずれて面倒なのと時間節約(今回位ではあまり変わりません)の為です。
※ 変数に日本語を使っているので意味は分かりやすいと思うのですが、嫌なら好きな単語に置換して下さい。
No.3
- 回答日時:
追加質問です
⑥ 元の表は最大で何行位でしょうか?
(「解読が楽なコード」と「スピード重視のコード」の判定に使わせていただきます)
⑦ 元の表のA列ですが1時的に使用して、終了時に自動でクリアするのは問題ありますか?
No.2
- 回答日時:
幾つか確認です。
① D列とF列が同じ場合B列C列G列J列はクリアするのではなく始に見つかったものにする。で宜しいですか?
② 元の表は枠を赤く囲むだけで残して、下に加工した表を作り直すわけですね。
③ 元の表と新しく作った表の間は何行必要でしょうか?
④ 写真を見ると表の外側の上部に1行数字が入っている行もコピーするという事ですね。
⑤ 初期は元の表しかなくて、その下は自由に使っていいのですよね?
![](http://oshiete.xgoo.jp/images/v2/common/profile/M/noimageicon_setting_14.png?e8efa67)
No.1
- 回答日時:
回答ではありません。
画像が不鮮明なので、アクセサリのsnipping toolを使って、画像を提示していただけませんでしょうか。
添付の画像もsnipping toolを使っています。
![「2列同じ値がある場合その行を統合して下部」の回答画像1](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/8/106271_5dbaf696416ab/M.png)
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VLOOKUPの列番号の最大は?
-
「段」と「行」の違いがよくわ...
-
LEFT関数とIF関数の組み合わせ...
-
エクセルで離れた列を選択して...
-
エクセルマクロPrivate Subを複...
-
VBA 指定した列にある日時デー...
-
アクセス 取り込み時に、桁数(...
-
Excelの行数、列数を増やしたい...
-
Excel文字列一括変換
-
エクセルで最初の行や列を開け...
-
エクセルでセル12個間隔で合...
-
Alt+Shift+↑を一括で行うには、...
-
別のブック最終行最終列の次へ...
-
エクセルで複数列の検索をマク...
-
EXCELを最大にて開いた際、特定...
-
エクセル マクロ 範囲指定で...
-
VBAで結合セルを転記する法を教...
-
VBA配列 列を指定する方法について
-
CSVファイルの「0落ち」にVBA
-
Accessのレポートで繰り返し表...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
「段」と「行」の違いがよくわ...
-
エクセルで離れた列を選択して...
-
VLOOKUPの列番号の最大は?
-
LEFT関数とIF関数の組み合わせ...
-
再質問です。マクロの修正箇所...
-
VBA 指定した列にある日時デー...
-
Alt+Shift+↑を一括で行うには、...
-
列方向、行方向の定義
-
リストからデータを紐付けしたい
-
エクセルマクロの組み方
-
Excelの行数、列数を増やしたい...
-
エクセルで複数列の検索をマク...
-
CSVファイルの「0落ち」にVBA
-
VBAで結合セルを転記する法を教...
-
VBAで別ブックの列を検索し、該...
-
エクセルマクロPrivate Subを複...
-
データシートビューのタイトル...
-
エクセルでセル12個間隔で合...
-
エクセルで最初の行や列を開け...
-
エクセルで住所を県と市・郡と...
おすすめ情報
すみませんよろしくお願いします。
③は、5、6行ぐらいでお願いします。
①、②、④、⑤はその通りです。
よろしくお願いします。
⑥最大で30行ぐらいです。
⑦問題ないです。
よろしくお願いします。
いろいろありがとうございます。会社で試してみます。