Excel VBAで１列に同じ値がある場合

質問

ExcelVBAで１列に同じ値が２つ以上ある場合、他の列を取り出すようにしたいです。

下記のようなテーブルがあった場合に、
No.4の値を２行から最終行まで、確認していき、
同じ値が２行以上あった場合に、それを１行にまとめて、
No.2に小さい値を、No.3に大きい値を書き込むようにしたいです。

例）
No.1 No.2 No.3 No.4 No.5
q 　　　1 　　　1 　　　1 　　　a
q 　　　2 　　　2 　　　1 　　　a
q 　　　3 　　　3 　　　1 　　　a

VBAで下記のようなテーブルにしたいです。
No.1 No.2 No.3 No.5
q 　　　1 　　　3 　　　a

当方、初心者でまだ日が浅いため、どうしても１行にまとめることができず、どなたか助けていただけますでしょうか。
回答よろしくお願いいたします。

回答No.5

kkkkkm

添付画像のようにNo.4に複数の別値が存在してそれぞれ一行にしたいという場合です。
4と1と5を一行にしています。5はもともと一行なのでそのまま。

Sub Test3()
Dim i As Long, LastRow As Long, LastRow2 As Long

Application.ScreenUpdating = False

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow
AutoFilterMode = False
LastRow2 = Cells(Rows.Count, "G").End(xlUp).Row + 1
If WorksheetFunction.CountIf(Range(Cells(i, "D"), Cells(LastRow, "D")), Cells(i, "D")) >= 2 And _
WorksheetFunction.CountIf(Range(Cells(2, "D"), Cells(i, "D")), Cells(i, "D")) = 1 Then
Range(Cells(1, "A"), Cells(LastRow, "E")).AutoFilter Field:=4, Criteria1:=Cells(i, "D").Value
Cells(LastRow2, "G").Value = Cells(i, "A").Value
Cells(LastRow2, "H").Value = WorksheetFunction.Subtotal(5, Range(Cells(2, "B"), Cells(LastRow, "B")))
Cells(LastRow2, "I").Value = WorksheetFunction.Subtotal(4, Range(Cells(2, "C"), Cells(LastRow, "C")))
Cells(LastRow2, "J").Value = Cells(i, "E").Value
ElseIf WorksheetFunction.CountIf(Range(Cells(2, "D"), Cells(LastRow, "D")), Cells(i, "D")) = 1 Then
Cells(LastRow2, "G").Value = Cells(i, "A").Value
Cells(LastRow2, "H").Value = Cells(i, "B").Value
Cells(LastRow2, "I").Value = Cells(i, "C").Value
Cells(LastRow2, "J").Value = Cells(i, "E").Value
End If
Next

Application.ScreenUpdating = True
End Sub

回答No.4

kkkkkm

テーブルが実際のテーブルだとしたら

Sheet2やテーブル1、テーブル2は実際のものに変更してください。
画像では左がテーブル1で右がテーブル2です。
テーブルは画像の位置に無くても大丈夫です。

Sub Test2()
Dim ws As Worksheet
Dim tbl As ListObject, tb2 As ListObject
Dim tblBody As Object, tb2Body As Object
Dim i As Long, LastRow As Long

Set ws = Sheets("Sheet2")
Set tbl = ws.ListObjects("テーブル1")
Set tb2 = ws.ListObjects("テーブル2")
Set tblBody = tbl.DataBodyRange
Set tb2Body = tb2.DataBodyRange

With tblBody
For i = .Rows.Count To 1 Step -1
If .Cells(i, 4).Value <> "" Then
LastRow = i
Exit For
End If
Next
For i = 1 To LastRow
If WorksheetFunction.CountIf(.Columns(4), .Cells(i, 4)) >= 2 Then
tb2Body.Cells(1, 1).Value = .Cells(1, 1).Value
tb2Body.Cells(1, 2).Value = Application.Min(Range(.Cells(1, 2), .Cells(LastRow, 2)))
tb2Body.Cells(1, 3).Value = Application.Max(Range(.Cells(1, 3), .Cells(LastRow, 3)))
tb2Body.Cells(1, 4).Value = .Cells(1, 5).Value
End If
Next
End With

Set ws = Nothing
Set tbl = Nothing
Set tb2 = Nothing
Set tblBody = Nothing
Set tb2Body = Nothing

End Sub

回答No.3

kkkkkm

テーブルというのは単に表の事を言っているとして
たとえば画像の位置にデータがあるとしたら

Sub Test()
Dim i As Long, LastRow As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow
If WorksheetFunction.CountIf(Range(Cells(2, "D"), Cells(LastRow, "D")), Cells(i, "D")) >= 2 Then
Range("G2").Value = Range("A2").Value
Range("H2").Value = Application.Min(Range(Cells(2, "B"), Cells(LastRow, "B")))
Range("I2").Value = Application.Max(Range(Cells(2, "C"), Cells(LastRow, "C")))
Range("J2").Value = Range("E2").Value
Exit For
End If
Next

End Sub

回答No.2

kon555

No1と5の扱いが分からないのですが、個々の機能について参考ページを挙げておきます。

>>２行から最終行まで、確認していき
https://excel-ubara.com/excelvba1r/EXCELVBA506.html

>>同じ値が２行以上あった場合に１行にまとめて
https://kirinote.com/excelvba-duplication-matome/

>>No.2に小さい値を、No.3に大きい値を
https://kirinote.com/excelvba-variable-max/
　最大最小値についてはもっと簡単な方法もありますが、初心者というならこの方法が良いと思います。

>>当方、初心者でまだ日が浅いため、
　初心者の方がやるには程よいレベルの課題になると思います。頑張ってみてください。

回答No.1

m5048172715

エクセル特有のステートメントを駆使してVBAを1行にまとめれば高速化できそうだが、それに拘らず、

セルの読み書き（この関数を最初に作る）、
forでループ、
ifで比較（代入演算子等を使う）、

を数行に別けてゆったり書いたほうがよい。
その3つで出来るよ。