VBA 整理资料及标示

On_fire

VBA 整理资料及标示

*

Sheet1是源资料,

A列是关键词, 每一行是一组数据, 行列是变量!

*

代码逻辑如下,

1.      根据每行的A列关键词, 顺序上到下, 左到右, 排到同一行

(  如Sheet1 (2), 关键词要加粗标红  )

2.      再判断每一行字符, 如有重复, 标黄底

*

最终的模拟结果Sheet1 (3)

*

数据N多, 恳请大神, 老师出手帮忙…谢谢!

chxw68

练练手。。

yynrzwh

Copy.zip (20.86 KB, 下载次数: 12)

2024-3-19 16:50 上传

点击文件名下载附件

On_fire

chxw68 发表于 2024-3-19 15:50
练练手。。

褚老师好,
好久没见您上來啦…新年好…!

On_fire

yynrzwh 发表于 2024-3-19 16:50

老师好,
感谢您…!

On_fire

chxw68 发表于 2024-3-19 15:50
练练手。。

褚老师,
早上好,
抱歉!!! 搞错了要求, 代码的逻辑有变,
判断条件原来是Copy and Paste, 不是Cut and Paste,
*原来是要求保留每一行的数据,
*当A列关键词相同, 就顺序上到下, 左到右, 复制另一行数据到本行
请您再看看文件, 帮忙优化….谢谢!!!

chxw68

重新写的。

125675117

留个记号，以后再学

On_fire

chxw68 发表于 2024-3-20 16:43
重新写的。

麻烦您, 褚老师, 感谢!

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, k&, n&, iColSize&, dic As Object, vTemp
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(1).[A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar) * UBound(ar, 2))
   
    For i = 1 To UBound(ar)
        n = 0
        For j = 1 To UBound(ar, 2)
            If Len(ar(i, j)) Then n = n + 1: br(i, n) = ar(i, j)
        Next j
        For k = 1 To UBound(ar)
            If k <> i Then
                 If ar(k, 1) = ar(i, 1) Then
                     For j = 1 To UBound(ar, 2)
                         If Len(ar(k, j)) Then n = n + 1: br(i, n) = ar(k, j)
                     Next j
                 End If
            End If
        Next k
        If n > iColSize Then iColSize = n
    Next i
   
    Cells.Delete
    With [A1].Resize(UBound(br), iColSize)
        .Value = br
        ar = .Value
        For i = 1 To UBound(ar)
            dic.RemoveAll: vTemp = ar(i, 1)
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then dic(ar(i, j)) = dic(ar(i, j)) + 1
            Next j
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then
                    With .Cells(i, j)
                        If ar(i, j) = vTemp Then .Font.Color = vbRed: .Font.Bold = True
                        If dic(ar(i, j)) > 1 Then .Interior.Color = vbYellow
                    End With
                End If
            Next j
        Next i
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub