同时具有4种情况，就根据H列最小值进行筛选A2到P1048576列

Nsp=娜！再来#

已解决，答案在4楼

情况1.B列冒号后面内容（B24）相同；
情况2.C列冒号后面内容（A211）也相同；
情况3.D列内容相同；
情况4.E列内容也相同；

同时具有上述4种情况，就根据H列最小值进行筛选A2:P1048576列，
请把筛选后的结果放在Sheets("结果")的A2，D:E列保持前面的数字0可见。
同时具有4种情况，就根据H列最小值进行筛选A2到P1048576列.zip (81.18 KB, 下载次数: 5)

2020-3-8 21:46 上传

点击文件名下载附件

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, t, dic(1), key, m
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Sheets("数据源").[a1].CurrentRegion.Offset(1).Value
  For i = 1 To UBound(arr, 1) - 1
    t = Split(arr(i, 2), ":")(1) & Split(arr(i, 3), ":")(1) & arr(i, 4) & arr(i, 5)
    If dic(0).exists(t) Then
      If dic(1)(t) > arr(i, 8) Then dic(0)(t) = i: dic(1)(t) = arr(i, 8)
    Else
      dic(0)(t) = i
      dic(1)(t) = arr(i, 8)
    End If
  Next
  ReDim brr(1 To dic(0).Count, 1 To UBound(arr, 2)) As String
  For Each key In dic(0).keys
    m = m + 1
    For j = 1 To UBound(arr, 2)
      brr(m, j) = arr(dic(0)(key), j)
    Next
  Next
  With Sheets("结果").[a2]
    .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

Nsp=娜！再来#

一把小刀闯天下 发表于 2020-3-8 22:22
Option Explicit

Sub test()

老师，
只有D:E列保持前面的数字0可见，
其他列的和原来的数据一样格式。

一把小刀闯天下

Nsp=娜！再来# 发表于 2020-3-8 22:27
老师，
只有D:E列保持前面的数字0可见，
其他列的和原来的数据一样格式。

Option Explicit

Sub test()
  Dim arr, i, j, t, dic(1), key, m
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Sheets("数据源").[a1].CurrentRegion.Offset(1).Value
  For i = 1 To UBound(arr, 1) - 1
    t = Split(arr(i, 2), ":")(1) & Split(arr(i, 3), ":")(1) & arr(i, 4) & arr(i, 5)
    If dic(0).exists(t) Then
      If dic(1)(t) > arr(i, 8) Then dic(0)(t) = i: dic(1)(t) = arr(i, 8)
    Else
      dic(0)(t) = i
      dic(1)(t) = arr(i, 8)
    End If
  Next
  ReDim brr(1 To dic(0).Count, 1 To UBound(arr, 2))
  For Each key In dic(0).keys
    m = m + 1
    For j = 1 To UBound(arr, 2)
      brr(m, j) = arr(dic(0)(key), j)
    Next
  Next
  With Sheets("结果")
    .[d:e].NumberFormatLocal = "@"
    With .[a2]
      .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
      .Resize(m, UBound(brr, 2)) = brr
    End With
  End With
End Sub