数组排序

kmcla

1、在excel中利用VBA在工作表1中第1列随机列出100个数，取值范围为[32,55]，保留小数点后1位数字。
2、在excel中利用VBA编程，找出第1题所列100个数中大于50的数字，并修改数据，使大于50的数字个数不超过3个。
3、在excel中利用VBA将第1题所列100个数经第2题修改后，随机拆分为5列，每列数字个数取值范围为[32,55]，第1、3列按升序排列，第2、4列按降序排列，第5列中位数为本列最大值，向上向下分别降序排列。

kmcla

我自己做完了。放这当学习记录

kmcla

Private Sub CommandButton1_Click()
    CommandButton1.Caption = [g3]
    Select Case [g3]
    Case "第一题"
        Call CommandButton2_Click
    Case "第二题"
        Call CommandButton3_Click
    Case "第三题"
        Call CommandButton4_Click
    Case Else
        CommandButton1.Caption = "不会"
    End Select
End Sub

kmcla

Private Sub CommandButton2_Click()
    Sheet1.Range("a1:e65535").ClearContents
    Dim arr(1 To 100)
    For i = 1 To 100
        arr(i) = Round(Rnd() * (55 - 32) + 32, 1)
    Next
    [a1].Resize(100, 1) = Application.Transpose(arr)
End Sub

kmcla

Private Sub CommandButton3_Click()
    '
    Sheet1.Range("a1:e65535").ClearContents
    Dim arr(1 To 100)
    For i = 1 To 100
        arr(i) = Round(Rnd() * (50 - 32) + 32, 1)
    Next
    [a1].Resize(100, 1) = Application.Transpose(arr)
    '
    For i = 1 To Int(Rnd() * 3 + 1)
        ii = Int(Rnd() * 100 + 1)
        Sheet1.Cells(ii, 1) = Round(50 + Rnd() * 5, 1)
    Next
End Sub

kmcla

Private Sub CommandButton4_Click()
    Call CommandButton3_Click
    '分五组
    Do
        a = 0
        arr1 = [a1].Resize(Int(Rnd * (23 - 16) + 16))
        a = UBound(arr1, 1)
        arr2 = Cells(a + 1, "a").Resize(Int(Rnd * (23 - 16) + 16))
        a = a + UBound(arr2, 1)
        arr3 = Cells(a + 1, "a").Resize(Int(Rnd * (23 - 16) + 16))
        a = a + UBound(arr3, 1)
        arr4 = Cells(a + 1, "a").Resize(Int(Rnd * (23 - 16) + 16))
        a = a + UBound(arr4, 1)
        arr5 = Cells(a + 1, "a").Resize(Int(Rnd * (23 - 16) + 16))
        a = a + UBound(arr5, 1)
    Loop Until a = 100
    ' 正排
    For j = 1 To UBound(arr1, 1)
        For k = j To UBound(arr1, 1)
            If arr1(j, 1) > arr1(k, 1) Then
                t = arr1(j, 1): arr1(j, 1) = arr1(k, 1): arr1(k, 1) = t '交换
            End If
        Next k
    Next j
    For j = 1 To UBound(arr3, 1)
        For k = j To UBound(arr3, 1)
            If arr3(j, 1) > arr3(k, 1) Then
                t = arr3(j, 1): arr3(j, 1) = arr3(k, 1): arr3(k, 1) = t '交换
            End If
        Next k
    Next j
    ' 反排
    For j = 1 To UBound(arr2, 1)
        For k = j To UBound(arr2, 1)
            If arr2(j, 1) < arr2(k, 1) Then
                t = arr2(j, 1): arr2(j, 1) = arr2(k, 1): arr2(k, 1) = t '交换
            End If
        Next k
    Next j
    For j = 1 To UBound(arr4, 1)
        For k = j To UBound(arr4, 1)
            If arr4(j, 1) < arr4(k, 1) Then
                t = arr4(j, 1): arr4(j, 1) = arr4(k, 1): arr4(k, 1) = t '交换
            End If
        Next k
    Next j
    ' 第5组正排
    For j = 1 To UBound(arr5, 1)
        For k = j To UBound(arr5, 1)
            If arr5(j, 1) > arr5(k, 1) Then
                t = arr5(j, 1): arr5(j, 1) = arr5(k, 1): arr5(k, 1) = t '交换
            End If
        Next k
    Next j
       ' 第5组分两小组
    t1 = 1
    t2 = 1
    tt = Int(UBound(arr5, 1) / 2)
    Dim arr51(), arr52()
    ReDim Preserve arr51(1 To UBound(arr5, 1) - tt, 1 To 1)
    ReDim Preserve arr52(1 To tt, 1 To 1)
        For j = 1 To UBound(arr5, 1)
        If j Mod 2 = 1 Then
            arr51(t1, 1) = arr5(j, 1)
            t1 = t1 + 1
        Else
            arr52(t2, 1) = arr5(j, 1)
            t2 = t2 + 1
        End If
    Next j
    ' 双数组反排
    For j = 1 To UBound(arr52, 1)
        For k = j To UBound(arr52, 1)
            If arr52(j, 1) < arr52(k, 1) Then
                t = arr52(j, 1): arr52(j, 1) = arr52(k, 1): arr52(k, 1) = t '交换
            End If
        Next k
    Next j
    ' 两小组合并
    For j = 1 To UBound(arr51, 1)
        arr5(j, 1) = arr51(j, 1)
    Next j
    For j = 1 To UBound(arr52, 1)
        arr5(UBound(arr51, 1) + j, 1) = arr52(j, 1)
    Next j
     ' 写入
    Sheet1.Range("a1:e65535").ClearContents
   
    [a1].Resize(UBound(arr1, 1)) = arr1
    [b1].Resize(UBound(arr2, 1)) = arr2
    [c1].Resize(UBound(arr3, 1)) = arr3
    [d1].Resize(UBound(arr4, 1)) = arr4
    [e1].Resize(UBound(arr5, 1)) = arr5
End Sub