VBA 计算一行不为零的中位数

niwopy

ykcbf1100

用公式就行了呗，用VBA写起来也麻烦。

niwopy

ykcbf1100 发表于 2024-1-27 16:46
用公式就行了呗，用VBA写起来也麻烦。

数据量大，公式运行太慢啊

fzxba

1. Sub test1()
   
2.   Dim ar, i As Long, j As Long, k As Long, p As Long
   
3.   
   
4.   ar = Range("W21:FM34").Value
   
5.   
   
6.   For i = 1 To UBound(ar)
   
7.     k = UBound(ar, 2)
   
8.     BubbleSort ar, i, i, 1, UBound(ar, 2), i
   
9.     For j = UBound(ar, 2) To 1 Step -1
   
10.       If ar(i, j) <= 0 Then k = k - 1 Else Exit For
    
11.     Next
    
12.     If k Then
    
13.       p = -Int(-k / 2)
    
14.       If k Mod 2 Then ar(i, 1) = ar(i, p) Else ar(i, 1) = (ar(i, p) + ar(i, p + 1)) / 2
    
15.     Else
    
16.       ar(i, 1) = ""
    
17.     End If
    
18.   Next
    
19.   Range("FP21").Resize(UBound(ar), 1) = ar
    
20. End Sub
    
21. 
    
22. Function BubbleSort(ar, u As Long, d As Long, l As Long, r As Long, p As Long)
    
23.   Dim i As Long, j As Long, x As Long, y As Long, Flag As Boolean, Swap As Double
    
24.   For j = l To r - 1
    
25.     Flag = True
    
26.     For x = l To r + l - 1 - j
    
27.       If ar(p, x) < ar(p, x + 1) Then
    
28.         Flag = False
    
29.         For y = u To d
    
30.           Swap = ar(y, x)
    
31.           ar(y, x) = ar(y, x + 1)
    
32.           ar(y, x + 1) = Swap
    
33.         Next
    
34.       End If
    
35.     Next
    
36.     If Flag = True Then Exit For
    
37.   Next
    
38. End Function

复制代码

过客fppt

参与一下:

1. Sub 计算除零以外的中位数()
   
2.     Dim arr, brr(), numbers() As Double
   
3.     arr = Range("W21").CurrentRegion
   
4.     ReDim brr(1 To UBound(arr, 1))
   
5.    
   
6.     Dim count As Long
   
7.     Dim i As Long, j As Long
   
8.     For i = 1 To UBound(arr, 1)
   
9.             count = 0
   
10.             ' 收集每一行中不为0的数值
    
11.         For j = 1 To UBound(arr, 2)
    
12.             If arr(i, j) <> 0 Then
    
13.                 count = count + 1
    
14.                 ReDim Preserve numbers(1 To count)
    
15.                 numbers(count) = arr(i, j)
    
16.             End If
    
17.         Next j
    
18.         brr(i) = CalculateMedianFromArray(numbers)
    
19.     Next i
    
20.     i = 1
    
21.     For Each rn In Range("FN21:FN34")
    
22.         rn.Value = brr(i)
    
23.         i = i + 1
    
24.     Next
    
25. End Sub
    
26. ' 中位数计算函数
    
27. Function CalculateMedianFromArray(numbers() As Double) As Double
    
28.     Dim count As Long
    
29.     count = UBound(numbers) - LBound(numbers) + 1
    
30.    
    
31.     ' 对数值数组进行排序
    
32.     Call QuickSort(numbers, LBound(numbers), UBound(numbers))
    
33.    
    
34.     ' 计算中位数
    
35.     If count Mod 2 = 0 Then
    
36.         CalculateMedianFromArray = (numbers(count / 2) + numbers(count / 2 + 1)) / 2
    
37.     Else
    
38.         CalculateMedianFromArray = numbers(count \ 2 + 1)
    
39.     End If
    
40. End Function
    
41. 
    
42. ' 快速排序算法
    
43. Sub QuickSort(arr() As Double, low As Long, high As Long)
    
44.     Dim i As Long, j As Long
    
45.     Dim pivot As Double, temp As Double
    
46.    
    
47.     i = low
    
48.     j = high
    
49.     pivot = arr((low + high) \ 2)
    
50.    
    
51.     Do While i <= j
    
52.         Do While arr(i) < pivot
    
53.             i = i + 1
    
54.         Loop
    
55.         Do While arr(j) > pivot
    
56.             j = j - 1
    
57.         Loop
    
58.         If i <= j Then
    
59.             temp = arr(i)
    
60.             arr(i) = arr(j)
    
61.             arr(j) = temp
    
62.             i = i + 1
    
63.             j = j - 1
    
64.         End If
    
65.     Loop
    
66.    
    
67.     If low < j Then QuickSort arr, low, j
    
68.     If i < high Then QuickSort arr, i, high
    
69. End Sub
    

复制代码

wfywc81

用ChatGPT花了1分钟写了一段代码，已验证测试，效果非常不错，请查收！

wfywc81

附：ChatGPT的prompt

编写一段VBA代码以执行以下任务：在Excel的"Sheet1"工作表上，从第21行开始，针对每一行，计算从"W"列起所有非零元素的中位数。然后，将这些中位数值显示在相应行的"FN"列中。为提高代码执行的效率，请在处理数据时采用数组。最后，请确保每个中位数结果在"FN"列中以红色加粗字体展示。此外，代码应能够测量并显示整个宏执行所需的时间。

附：所有非零元素的中位数计算步骤

要计算上述数据不为零的中位数，我们首先需要从给出的数据中排除所有的零值，然后对剩余的数据进行排序。排序后，我们可以找到中位数，即位于排序后列表中间的数字。如果数据集中有奇数个数字，中位数就是中间的数字；如果数据集中有偶数个数字，则中位数是中间两个数字的平均值。

下面是计算步骤：

1.移除所有的零值。

2.将剩余的数据按从小到大的顺序排序。

3.如果数据集的数量是奇数，则中位数是中间的数值。

4.如果数据集的数量是偶数，则中位数是中间两个数值的平均值。

附：VBA代码执行过程

要在Excel中自动化计算"Sheet1"的每行数据（从第21行起，从"W"列开始）中非零元素的中位数，并将结果以红色加粗字体在"FN"列显示，同时跟踪并展示宏的执行时间，你可以按照以下步骤编写和执行一个VBA宏：

1、初始化和设置环境：在VBA编辑器中，创建一个新的宏，首先设置目标工作表为"Sheet1"，并初始化所有必要的变量，包括计时器变量、数据存储数组、行列计数器等。

2、启动计时器：使用Timer函数开始记录宏的执行时间，以便于最后计算整个宏运行所需的时间。

3、定义数据范围：确定数据的起始点为第21行的"W"列，并找到从这一点开始到最后一行以及最右边有数据的列的范围。

4、数组处理：将选定范围的数据读入到一个数组中，以提高数据处理的效率和速度。

5、中位数计算：

遍历数组的每一行，为每行创建一个临时数组以存储非零元素。

将非零元素收集到临时数组后，进行排序。

根据临时数组的元素数量，计算中位数。对于偶数个元素的数组，中位数是中间两个数的平均值；对于奇数个元素的数组，中位数是中间的数。

结果展示：将每行计算出的中位数写入对应的"FN"列，并设置字体颜色为红色且加粗，以便结果清晰可见。

6、计时结束和展示：在所有计算完成后，再次使用Timer函数记录时间，并计算总的执行时间。通过消息框展示给用户，告知宏的运行时间。

micch

1. Sub Main()
   
2.     For r = 21 To 34
   
3.         ar = Range("W" & r & ":FM" & r).Value
   
4.         myMedian ar, Cells(r, "FP")
   
5.     Next
   
6. End Sub
   
7. Function myMedian(arr, rng As Range)
   
8.     For i = 1 To UBound(arr, 2) - 1
   
9.         For j = i + 1 To UBound(arr, 2)
   
10.             If arr(1, j) > arr(1, i) Then
    
11.                 x = arr(1, i)
    
12.                 arr(1, i) = arr(1, j)
    
13.                 arr(1, j) = x
    
14.             End If
    
15.         Next
    
16.         If VBA.Len(arr(1, i)) = 0 Then Exit For
    
17.     Next
    
18.     If i Mod 2 Then
    
19.         rng.Value = (arr(1, i \ 2) + arr(1, i \ 2 + 1)) / 2
    
20.     Else
    
21.         rng.Value = arr(1, i \ 2)
    
22.     End If
    
23. End Function

复制代码

lizhipei78

中位数是啥都不知道了，哎，忘记完了