集中

ddz79101

ynzsvt 发表于 2024-11-16 15:12
这是d列的筛选，辅助C列的筛选空白即可。

谢谢老师！我看了我的版本，感觉不能满足我的虽在B列但金额在D列的重复姓名。且姓名若大于三个，输姓名麻烦。

ynzsvt

你的是排序，我说的是筛选，也可以用如下图的pQl两列高级筛选。

ynzsvt

换个图片明白点

翁知江安

Sub 集中()
Dim i, j, m, p, irow
Dim arr, brr
irow = Sheet1.[b65536].End(xlUp).Row
arr = Sheet1.Range("a1:f" & irow)
ReDim brr(1 To irow - 1, 1 To 6)
ReDim crr(1 To irow - 1, 1 To 6)
Sheet1.[i1].Resize(irow, 6).Clear
For i = 2 To UBound(arr)
  If Sheet1.Cells(i, 2).Interior.Color <> RGB(255, 255, 255) Then
     m = m + 1
     For j = 1 To 6
     brr(m, j) = arr(i, j)
     Next
    Else
    p = p + 1
    For j = 1 To 6
    crr(p, j) = arr(i, j)
    Next
    End If
Next
Sheet1.[a1].Resize(1, 6).Copy Sheet1.[i1]
Sheet1.[i2].Resize(p, 6) = crr
Sheet1.Cells(2 + p, 9).Resize(m, 6) = brr
Sheet1.Cells(2 + p, 9).Resize(m, 6).Interior.Color = vbRed
End Sub

翁知江安

颜色随便选了红色，如需修改，可修改代码。以上供参考，欢迎批评指正。

ddz79101

翁知江安 发表于 2024-11-16 15:51
颜色随便选了红色，如需修改，可修改代码。以上供参考，欢迎批评指正。

谢谢老师！运行顺利。可能我讨教附件存涂色，本意为提示，不是按颜色排序。原表中无涂色。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, rng1 As Range, rng2 As Range, r&
   
    With [A1].CurrentRegion
    ar = .Value
    For i = 1 To UBound(ar)
        If .Cells(i, 2).Interior.ColorIndex = -4142 Then
            If rng1 Is Nothing Then
                Set rng1 = .Rows(i)
            Else
                Set rng1 = Union(rng1, .Rows(i))
            End If
        Else
            If rng2 Is Nothing Then
                Set rng2 = .Rows(i)
            Else
                Set rng2 = Union(rng2, .Rows(i))
            End If
        End If
    Next i
    End With
   
    Columns("I:N").Clear
    rng1.Copy [I1]
    If Not rng2 Is Nothing Then
        r = Cells(Rows.Count, "J").End(xlUp).Row
        rng2.Copy Cells(r, "i")
    End If
    Beep
End Sub

gwjkkkkk

请参考。。。

ddz79101

gwjkkkkk 发表于 2024-11-16 18:06
请参考。。。

谢谢老师！运行顺利！我可能没有说明白，不是按附件中的颜色排序，源表中没有涂色的，涂色只是为了说明。重传附件

gwjkkkkk

ddz79101 发表于 2024-11-16 18:46
谢谢老师！运行顺利！我可能没有说明白，不是按附件中的颜色排序，源表中没有涂色的，涂色只是为了说明。 ...

Option Explicit
Sub test()
    Dim ar, i&, j&, k&, rng1 As Range, rng2 As Range, r&, vTemp1, vTemp2
   
    r = Cells(Rows.Count, "B").End(xlUp).Row
    ar = Range("A1:H" & r).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
    r = 1
    For j = 1 To UBound(ar, 2)
        br(1, j) = ar(1, j)
    Next j
    For i = 1 To 2
        If i = 2 Then vTemp1 = "找到组织": vTemp2 = "过组织生活"
        For k = 2 To UBound(ar)
            If ar(k, 8) = vTemp1 Then
                r = r + 1
                For j = 1 To UBound(ar, 2)
                    br(r, j) = ar(k, j)
                Next j
                br(r, UBound(br, 2)) = vTemp2
            End If
        Next k
    Next i
   
    Columns("L:S").Clear
    [L1].Resize(UBound(br), UBound(br, 2)) = br
    Beep
End Sub