VBA 数据整理

On_fire

gwjkkkkk 发表于 2024-3-5 12:10
楼主又来出题了。

老师好,
您见笑了…

gwjkkkkk

On_fire 发表于 2024-3-5 15:09
老师好,
您见笑了…

也不错，动动脑子嘛。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, k&, r&, n&, dic As Object, vTemp
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(1).UsedRange.Value
    ActiveSheet.UsedRange.Borders.LineStyle = xlNone
   
    For i = 1 To UBound(ar)
        dic.RemoveAll
        For j = 1 To UBound(ar, 2)
             If Len(ar(i, j)) Then dic(ar(i, j)) = Empty
        Next j
        ReDim br(1 To dic.Count, 1 To dic.Count)
        r = 0: cr = dic.keys
        For j = 0 To UBound(cr)
            vTemp = cr(j): cr(j) = cr(0): cr(0) = vTemp
            r = r + 1
            For k = 0 To UBound(cr)
                br(r, k + 1) = cr(k)
            Next k
        Next j
        Cells(n + dic.Count, 1).Resize(, UBound(br)).Borders(9).LineStyle = xlContinuous
        Cells(n + 1, 1).Resize(UBound(br), UBound(br, 2)) = br
        n = n + dic.Count
    Next i
   
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

yynrzwh

rebuilt.zip (19.52 KB, 下载次数: 7)

2024-3-5 21:01 上传

点击文件名下载附件