多列转一列 升序排列去重复

ba3259878266

多列转一列 升序排列去重复  谢谢各位师傅帮忙

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, n, t, arr, m
  arr = Sheets("sheet1").UsedRange.Value
  ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 1) As String
  For j = 1 To 5 Step 2
    For i = 1 To UBound(arr, 1)
      If Len(arr(i, j)) > 0 Then
        n = n + 1: brr(n, 1) = arr(i, j)
      End If
  Next i, j
  For i = 1 To n - 1
    For j = i + 1 To n
      If Val(brr(i, 1)) > Val(brr(j, 1)) Then
        t = brr(i, 1): brr(i, 1) = brr(j, 1): brr(j, 1) = t
      End If
  Next j, i
  For i = 1 To n
    For j = i To n
      If brr(j, 1) <> brr(j + 1, 1) Then
        m = m + 1: brr(m, 1) = brr(i, 1)
        i = j: Exit For
      End If
  Next j, i
  With [g:g]
    .ClearContents
    .Resize(m) = brr
  End With
End Sub

ba3259878266

一把小刀闯天下 发表于 2018-9-2 13:56
Option Explicit

Sub test()

师傅 谢谢 很好用 能说明一下 代表A列 C列 E列 是哪些代码吗 以便必要是修改

一把小刀闯天下

ba3259878266 发表于 2018-9-2 14:42
师傅 谢谢 很好用 能说明一下 代表A列 C列 E列 是哪些代码吗 以便必要是修改

Option Explicit

Sub test()
  Dim i, j, n, t, arr, m
  arr = Sheets("sheet1").UsedRange.Value
  ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 1) As String
  For j = 1 To 5 Step 2 '1就是A列，step 2 就是隔列，也就是取A、C、E数据
    For i = 1 To UBound(arr, 1) '浏览指定列行数据
      If Len(arr(i, j)) > 0 Then '非空
        n = n + 1: brr(n, 1) = arr(i, j) '写入brr数组
      End If
  Next i, j
  For i = 1 To n - 1 '对获取的n个数进行升序（数据量大换快排，这里采用的是史上最笨的排序法，但简单）
    For j = i + 1 To n
      If Val(brr(i, 1)) > Val(brr(j, 1)) Then
        t = brr(i, 1): brr(i, 1) = brr(j, 1): brr(j, 1) = t
      End If
  Next j, i
  For i = 1 To n '去重，因为n个数据已经是有序了，所以用这方法去重效率非常高
    For j = i To n
      If brr(j, 1) <> brr(j + 1, 1) Then '当与下个数据不同时取本次循环的第一个数
        m = m + 1: brr(m, 1) = brr(i, 1)
        i = j: Exit For '可以看到2个循环其实循环数仅为n，所以效率高
      End If
  Next j, i
  With [g:g] '指定G列输出，G1开始
    .ClearContents '清除上次可能存在的数据
    .Resize(m) = brr
  End With
End Sub

Kaohsing

'js

1. Sub js_kao()
   
2.     Dim k%
   
3.     Dim kk$
   
4.     Dim x As Object
   
5.     Dim arr, ar, a()
   
6.     arr = [a:e]
   
7.     Set x = CreateObject("scriptcontrol")
   
8.     x.Language = "javascript"
   
9.    
   
10.     For Each ar In arr
    
11.         If Len(ar) > 0 Then
    
12.             k = k + 1
    
13.             ReDim Preserve a(1 To k)
    
14.             a(k) = ar
    
15.         End If
    
16.     Next
    
17.     x.addcode "function aa(bb){x=bb.split(',');x.sort(function(x,y){return x-y});return x;}"
    
18.     If k > 0 Then [g1].Resize(k, 1) = Application.Transpose(Split(x.eval("aa('" & Join(a, ",") & "')"), ","))
    
19. End Sub

复制代码

ba3259878266

一把小刀闯天下 发表于 2018-9-2 13:56
Option Explicit

Sub test()

师傅 弄明白了 谢谢你

hcm19522

J2:J11{=IFERROR(TEXT(SMALL(IF((A$1:E$9*1>0)*(COUNTIF(J$1:J1,A$1:E$9)=0),A$1:E$9*1),1),"0000"),"")

chaohuahch

一把小刀闯天下 发表于 2018-9-2 14:52
Option Explicit

Sub test()

冒泡排序法，感觉不好用。这给例子，可以用sort来解决排序的问题。

chaohuahch

代码如下：

1. Sub fyExcelVBA()
   
2. Dim arr, brr(), i%, j%, n%, nRow%
   
3. Dim dic As Object
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. arr = Sheets("sheet1").UsedRange.Value
   
6. For i = 1 To UBound(arr)
   
7.     For j = 1 To UBound(arr, 2)
   
8.          If Len(arr(i, j)) Then dic(CInt(arr(i, j))) = ""
   
9.     Next j
   
10. Next i
    
11. n = dic.Count
    
12. ReDim brr(1 To n, 1 To 1)
    
13. For Each a In dic.keys
    
14.        k = k + 1
    
15.        brr(k, 1) = a
    
16. Next
    
17. Sheets("sheet1").Range("g1").Resize(n) = brr
    
18. nRow = Range("g" & Rows.Count).End(3).Row
    
19. With Sheets("sheet1").Range("g1:g" & nRow)
    
20.       .Sort key1:=Range("g1"), Order1:=xlAscending
    
21. End With
    
22. Set dic = Nothing
    
23. End Sub
    

复制代码

一把小刀闯天下

chaohuahch 发表于 2018-9-2 20:12
冒泡排序法，感觉不好用。这给例子，可以用sort来解决排序的问题。

不太会用工作表的sort来排序

小规模数据可以用选择或冒泡来排序。我用的是非稳定性的选择排序，效率当然非常差，但它的代码非常简洁而且结果肯定也没有毛病的。冒泡为稳定性排序，一般情况下二者效率相同，但特殊情况下（有序）它的时间复杂度为n，而选择排序的时间复杂度永远为n^2。大规模数据当然首选使用快排，但如果对稳定性有要求一般选用归并排序。这论坛我看到过有大神把快排改成稳定排序了，不过我更喜欢用归并，因为它象坦克一样稳定，，，。