初めて自分の家と他人の家が違う、と意識した時

急いでいます！

2列同じ値がある場合その行を統合して下部に他のデータと一緒に表示するエクセルvbaのコード

解決済

  • 質問者：pedro21
  • 質問日時：
  • 回答数：6件

エクセルvba初心者です。

以下のことを見様見真似でエクセルVBAのコード書こうとしたら上手くいきませんでした。
すみませんがコードを教えていただければと思います。

①エクセルシートにある値がD列とＦ列ともに同じである行のD列とＦ列のセルを赤い罫線で囲む。
②①の行の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行目のＨ、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列同じ値がある場合その行を統合して下部」の質問画像

質問者からの補足コメント

  • すみませんよろしくお願いします。

    「2列同じ値がある場合その行を統合して下部」の補足画像1
    No.1の回答に寄せられた補足コメントです。 補足日時：2019/11/01 00:54
    通報する

  • ③は、5、6行ぐらいでお願いします。
    ①、②、④、⑤はその通りです。

    よろしくお願いします。

    No.2の回答に寄せられた補足コメントです。 補足日時：2019/11/01 01:05
    通報する

  • ⑥最大で30行ぐらいです。
    ⑦問題ないです。

    よろしくお願いします。

    No.3の回答に寄せられた補足コメントです。 補足日時：2019/11/01 01:13
    通報する

  • いろいろありがとうございます。会社で試してみます。

    No.6の回答に寄せられた補足コメントです。 補足日時：2019/11/01 07:30
    通報する
通報する

この質問は特に50代・男性の方に
リクエストされています！
(回答を制限するものではありません。)

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (6件)

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
この回答への補足あり
    • good
    • 0
    • 件
通報する
この回答へのお礼

完璧です。ありがとうございました。助かりました。

通報する
お礼日時：2019/11/01 09:17

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 罫線色付」は呼び出す側で色の指定も可能です。何も指定しない場合は「赤」が指定されたことになっています。
    • good
    • 0
    • 件
通報する

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_元行
　　　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列をクリアしています。

※ 途中、行削除ではなくクリアしているのは行がずれて面倒なのと時間節約（今回位ではあまり変わりません）の為です。
※ 変数に日本語を使っているので意味は分かりやすいと思うのですが、嫌なら好きな単語に置換して下さい。
    • good
    • 0
    • 件
通報する

No.3

追加質問です


⑥ 元の表は最大で何行位でしょうか？
（「解読が楽なコード」と「スピード重視のコード」の判定に使わせていただきます）
⑦ 元の表のＡ列ですが１時的に使用して、終了時に自動でクリアするのは問題ありますか？
この回答への補足あり
    • good
    • 0
    • 件
通報する

No.2

幾つか確認です。


① Ｄ列とＦ列が同じ場合Ｂ列Ｃ列Ｇ列Ｊ列はクリアするのではなく始に見つかったものにする。で宜しいですか？
② 元の表は枠を赤く囲むだけで残して、下に加工した表を作り直すわけですね。
③ 元の表と新しく作った表の間は何行必要でしょうか？
④ 写真を見ると表の外側の上部に１行数字が入っている行もコピーするという事ですね。
⑤ 初期は元の表しかなくて、その下は自由に使っていいのですよね？
この回答への補足あり
    • good
    • 1
    • 件
通報する

No.1

  • 回答者： tatsu99
  • 回答日時：

回答ではありません。


画像が不鮮明なので、アクセサリのsnipping toolを使って、画像を提示していただけませんでしょうか。
添付の画像もsnipping toolを使っています。
「2列同じ値がある場合その行を統合して下部」の回答画像1
この回答への補足あり
    • good
    • 2
    • 件
通報する

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

ページトップページトップ

Q質問する（無料）

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

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

おすすめ情報