VBA提取特殊数据及重新排序

On_fire

VBA提取特殊数据及重新排序

*

Sheet1是源數据,

每一行是独立的数据,

行及列数不固定.

*

*

计算逻辑:

只提取每一行特殊的内容的单元格 (前缀数字 = ?.?) ,

及

重新排序后( 根据数值, 由小到大, 升序 ), 再赋值

*

*

N多数据, 请老师/大神帮帮忙…

flyfairy

这个估计得用正则表达式,要不好像比较麻烦.

一把小刀闯天下

'按结果凑了一个，，

Option Explicit

Sub test()
  Dim arr, i, j, k, n, t
  arr = Sheets("sheet1").UsedRange.Value
  For i = 1 To UBound(arr, 1)
    n = 2
    For j = 3 To UBound(arr, 2)
      If InStr(arr(i, j), ".") Then n = n + 1: arr(i, n) = arr(i, j)
      If j > n Then arr(i, j) = vbNullString
    Next
    For j = 3 To n - 1
      For k = j + 1 To n
        If Val(arr(i, j)) > Val(arr(i, k)) Then
          t = arr(i, j): arr(i, j) = arr(i, k): arr(i, k) = t
        End If
      Next
    Next
  Next
  Sheets("Sheet1 (2)").[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

笨鸟飞不高

Sub AwTest()
    Dim i%, j%, c%, n%, r%, arr, temp
    Sheet1.Select
    arr = ActiveSheet.UsedRange
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        c = 0
        For j = 1 To UBound(arr, 2)
            If Val(arr(i, j)) > 0 Then
                c = c + 1
                brr(i, c) = arr(i, j)
            End If
            n = IIf(n > c, n, c)
        Next
    Next
    For i = 1 To UBound(brr)
        For j = 3 To n - 1
            For r = j + 1 To n
                If Len(brr(i, j)) > 0 And Len(brr(i, r)) > 0 Then
                    If Val(brr(i, j)) > Val(brr(i, r)) Then
                        temp = brr(i, j)
                        brr(i, j) = brr(i, r)
                        brr(i, r) = temp
                    End If
                End If
            Next
        Next
    Next
    [r1].Resize(UBound(brr), n) = brr
End Sub

凑一个！

笨鸟飞不高

Rank.zip (17.37 KB, 下载次数: 11)

2020-9-22 15:53 上传

点击文件名下载附件

On_fire

笨鸟飞不高 发表于 2020-9-22 15:53

谢谢老师,

请帮忙修改一下代码,
把计算结果输出到另一页, 比如Sheet2…

笨鸟飞不高

On_fire 发表于 2020-9-22 16:10
谢谢老师,

请帮忙修改一下代码,

Sub AwTest()
    Dim i%, j%, c%, n%, r%, arr, temp
    Sheet1.Select
    arr = ActiveSheet.UsedRange
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        c = 0
        For j = 1 To UBound(arr, 2)
            If Val(arr(i, j)) > 0 Then
                c = c + 1
                brr(i, c) = arr(i, j)
            End If
            n = IIf(n > c, n, c)
        Next
    Next
    For i = 1 To UBound(brr)
        For j = 3 To n - 1
            For r = j + 1 To n
                If Len(brr(i, j)) > 0 And Len(brr(i, r)) > 0 Then
                    If Val(brr(i, j)) > Val(brr(i, r)) Then
                        temp = brr(i, j)
                        brr(i, j) = brr(i, r)
                        brr(i, r) = temp
                    End If
                End If
            Next
        Next
    Next
    With Sheet2
        .Cells.Clear
        .[a1].Resize(UBound(brr), n) = brr
    End With
End Sub

笨鸟飞不高

Rank.zip (17.71 KB, 下载次数: 6)

2020-9-22 16:18 上传

点击文件名下载附件

鄂龙蒙

1. Sub 统计()
   
2.     Dim m, i, j, arr, brr(), crr()
   
3.     Range("R1:AE65536") = ""
   
4.     arr = Range("A1:N" & [A65536].End(3).Row)
   
5.     ReDim brr(1 To UBound(arr), 1 To 14)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 1 To 2
   
8.             brr(i, j) = arr(i, j)
   
9.         Next
   
10.         m = 2
    
11.         For j = 3 To UBound(arr, 2)
    
12.             If Left(arr(i, j), 1) Like "[0-9]" Then
    
13.                 m = m + 1
    
14.                 brr(i, m) = arr(i, j)
    
15.             End If
    
16.         Next
    
17.         ReDim crr(1 To 1, 1 To m - 2)
    
18.         For j = 3 To m
    
19.             crr(1, j - 2) = brr(i, j)
    
20.         Next
    
21.         Call dsort(crr)
    
22.         For j = 3 To m
    
23.             brr(i, j) = crr(1, j - 2)
    
24.         Next
    
25.         Erase crr
    
26.     Next
    
27.     [R1].Resize(UBound(brr), 14) = brr
    
28. End Sub
    
29. 
    
30. Function dsort(arr)
    
31.     Dim i, j, a, b, t
    
32.     For i = 1 To UBound(arr, 2) - 1
    
33.         For j = i + 1 To UBound(arr, 2)
    
34.             a = Val(Mid(arr(1, i), 1, Len(arr(1, i)) - 2))
    
35.             b = Val(Mid(arr(1, j), 1, Len(arr(1, j)) - 2))
    
36.             If a > b Then
    
37.                 t = arr(1, i)
    
38.                 arr(1, i) = arr(1, j)
    
39.                 arr(1, j) = t
    
40.             End If
    
41.         Next
    
42.     Next
    
43. End Function

复制代码

On_fire

笨鸟飞不高 发表于 2020-9-22 16:18

老师好,
改一下源数据, 发现计算结果不对,
少了2列, 排序也不对?

请您看一看?