求个可以把分散的数据集中放在一起的程序

gzminge

求把BP1265：CI1275的所有数据集中起来，按从小到大的顺序放在AR1244的下面；


求把CK1265：DD1275的所有数据集中起来，按从小到大的顺序放在AS1244的下面；



（111）.rar (56.55 KB, 下载次数: 8)

2024-8-10 00:33 上传

点击文件名下载附件

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test0810()
Dim i&, j&, arr, rng As Range, brr, t&
    With Worksheets("每天")
        Set rng = .Range("BP1265：CI1275")
        arr = rng.Value
        ReDim brr(1 To 100000, 1 To 2)
        For i = 1 To UBound(arr)
            For j = 1 To UBound(arr, 2)
                If Len(arr(i, j)) > 0 Then
                    n = n + 1
                    brr(n, 1) = n
                    brr(n, 2) = arr(i, j)
                End If
            Next
        Next
        For i = 1 To n - 1
            For j = i + 1 To n
                If brr(i, 2) > brr(j, 2) Then
                    t = brr(i, 2)
                    brr(i, 2) = brr(j, 2)
                    brr(j, 2) = t
                End If
            Next
        Next
        .[ar1244].Resize(n, 2) = brr
    End With
    Beep
End Sub

gzminge

quqiyuan 发表于 2024-8-10 07:48
参与一下，仅供参考。。。

早上好，BP1265：CI1275里面原来没有4 5 6 7 ，现在多出来一些数，不准确。
CK1265：DD1275也一样，原来没有的数，现在多出来，不准确。

quqiyuan

gzminge 发表于 2024-8-10 08:02
早上好，BP1265：CI1275里面原来没有4 5 6 7 ，现在多出来一些数，不准确。
CK1265：DD1275也一样，原来 ...

给你写上顺序了

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br(), i&, j&, k&, r&
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To 2)
    ar(1) = [BP1265:CI1275].Value
    ar(2) = [CK1265:DD1275]
   
    With [AR1244]
        For k = 1 To 2
            Erase br(): r = 0
            For i = 1 To UBound(ar(k))
                For j = 1 To UBound(ar(k), 2)
                        If Len(ar(k)(i, j)) Then
                        r = r + 1
                        ReDim Preserve br(1 To r)
                        br(r) = ar(k)(i, j)
                    End If
                Next j
            Next i
            If r Then
                bSort1 br, 1, UBound(br)
                .Cells(1, k).Resize(UBound(br)) = Application.Transpose(br)
            End If
        Next k
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub


Function bSort1(ByRef ar, ByVal iFirst&, ByVal iLast&, _
    Optional ByVal isOrder As Boolean = True)
    Dim i&, j&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j) <> ar(j + 1) Then
                If ar(j) < ar(j + 1) Xor isOrder Then
                    vTemp = ar(j)
                    ar(j) = ar(j + 1)
                    ar(j + 1) = vTemp
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

...............