VBA 资料整理

On_fire

VBA 资料整理

*

Sheet1是源数据, 每一行是一组资料, 行列是变量

*

代码逻辑如下,

1.      顺序上到下, 判断每一行有多少个单元格?

2.      判断每一行的单元格的数量, 由多到少, 顺序上到下重新排

( 要含格式, 结果/效果跟Cut & Insert相似 )

*

模拟结果在Sheet1(2)

*

要处理的行数比较多,

恳请大神, 老师出手帮忙...谢谢!

limonet

1、1与2行，为什么A在上？
2、3与4行，为什么A在下？
3、第9行为什么与第7行不挨着？

On_fire

limonet 发表于 2024-4-8 19:19
1、1与2行，为什么A在上？
2、3与4行，为什么A在下？
3、第9行为什么与第7行不挨着？

老师好,
ABCD的这一行跟1234这一行, 都是4个单元格
*
在Sheet1页中,
ABCD是第4行, 排到最前, 1234是第8行, 紧随其后,
123是第3行, 排到靠前, ABC是第6行, 紧随其后,
如此类推…

gwjkkkkk

Option Explicit
Sub TEST4()
    Dim ar, br, i&, n&, t#
   
    Application.ScreenUpdating = False
    t = Timer
   
    With Sheets(1).[A1].CurrentRegion
        ar = .Value
        ReDim br(1 To UBound(ar), 1 To 2)
        For i = 1 To UBound(ar)
            br(i, 1) = i
            n = 0
            For j = 1 To UBound(ar, 2)
                If Len(ar(i, j)) Then n = n + 1
            Next j
            br(i, 2) = n
        Next i
        Cells.Clear
        bSort br, 1, UBound(br), 1, UBound(br, 2), 2, False
        Cells.Clear
        For i = 1 To UBound(br)
            .Rows(br(i, 1)).Copy Cells(i, 1)
        Next i
    End With
   
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function bSort(ar, iFirst&, iLast&, iLeft&, iRight&, _
    iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k): ar(j, k) = ar(j + 1, k): ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

请参考附件。。。

yynrzwh

Sub test()

Application.ScreenUpdating = False
With Sheet1
    lc = .UsedRange.Columns.Count
    lr = .UsedRange.Rows.Count
    For i = 1 To lr
        .Cells(i, lc + 1) = WorksheetFunction.CountA(.Range(.Cells(i, 1), .Cells(i, lc)))
    Next
    .Range("a1").Resize(lr, lc + 1).Sort .Cells(1, lc + 1), xlDescending
    .Columns(lc + 1).Delete
End With
Application.ScreenUpdating = True

End Sub

On_fire

gwjkkkkk 发表于 2024-4-8 19:47
请参考附件。。。

早上好, 感谢老师…

On_fire

yynrzwh 发表于 2024-4-8 22:45
Sub test()

Application.ScreenUpdating = False

早上好, 谢谢老师…