求助大神如何排序附件的数据

zy89021098

大神：
        第一行是我希望的参数名排序，第二行是顺序打乱了的参数名，麻烦编个程序把第二行及以下的数据对应到第一行相应参数名下面，谢谢！
       第二行的参数名个数可能比第一行多，多出来的列就放数据的最后面。

Jason_WangSS

1. Sub 排列()
   
2. Dim arr, brr
   
3. 
   
4. arr = Range("a2", Cells([a2].End(xlDown).Row, [a2].EntireRow.Columns.Count).End(xlToLeft))
   
5. 
   
6. 'Range("a2", [a2].End(xlDown)).EntireRow.ClearContents '需要删除源数据,解除注释
   
7. 
   
8. ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
   
9. a = 1
   
10. For Each Rng In Range("a1", [a1].End(xlToRight))
    
11.     For i = 1 To UBound(arr, 2) '循环比较数组首行与目标序列
    
12.         If arr(1, i) = Rng Then
    
13.         
    
14.         For j = 1 To UBound(arr, 1) '循环赋值
    
15.             brr(j, a) = arr(j, i) 'arr赋值给brr
    
16.         Next
    
17.         a = a + 1 'brr 列往后推移
    
18.         End If
    
19.     Next
    
20. Next
    
21. Range("a40").Resize(UBound(brr, 1), UBound(brr, 2)) = brr '输出位置
    
22. End Sub
    

复制代码

试试看，是不是你要的

zy89021098

Jason_WangSS 发表于 2019-9-7 16:10
试试看，是不是你要的

运行宏后，除了里面第二行以下数据被清空，没有其他动作哦

Jason_WangSS

zy89021098 发表于 2019-9-7 16:56
运行宏后，除了里面第二行以下数据被清空，没有其他动作哦

你仔细看一下，40行是不是有数据
还有，不要重复运行

deadzlq

PQ参考解法

deadzlq

468列 配 521列 ，好冗余的数据库表

zy89021098

Jason_WangSS 发表于 2019-9-7 17:13
你仔细看一下，40行是不是有数据
还有，不要重复运行

谢谢大神，但有一个问题，看BB列，如果第一行有的参数第二行没有，就会出现错行，我希望是第一行有的参数第二行没有，那这列参数下面就空着，如果第二行有的参数第一行没有，那这个参数下的数据就放在全部数据的最后面，大神有没有好办法，跪拜！！！

Jason_WangSS

zy89021098 发表于 2019-9-9 15:35
谢谢大神，但有一个问题，看BB列，如果第一行有的参数第二行没有，就会出现错行，我希望是第一行有的参数 ...

1. Sub 排序()
   
2.     Dim arr, brr, crr, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.    
   
5.     For Each Rng In Range("a1", Cells(2, Cells(1, Columns.Count).End(xlToLeft).Column))
   
6.         d(Rng.Text) = d(Rng.Text)
   
7.     Next
   
8.     brr = Range("a2", Cells([a1].End(xlDown).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
   
9.    
   
10.     ReDim arr(1 To UBound(brr, 1) + 1, 1 To d.Count)
    
11.     crr = d.keys
    
12.    
    
13.     For i = 1 To d.Count
    
14.         arr(1, i) = crr(i - 1)
    
15.     Next
    
16.    
    
17.     For i = 1 To UBound(arr, 2)
    
18.         For j = 1 To UBound(brr, 2)
    
19.             If brr(1, j) = arr(1, i) Then
    
20.                 For k = 1 To UBound(brr, 1) - 1
    
21.                     arr(k + 1, i) = brr(k + 1, j)
    
22.                 Next
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     [a40].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
27. End Sub
    

复制代码

zy89021098

Jason_WangSS 发表于 2019-9-9 20:28

大神，还是有错行，不知道什么原因，麻烦看看，见附件图片。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, brr, i, j, cnt, p, dic, t
  Set dic = CreateObject("scripting.dictionary")
  cnt = [a1].End(xlToRight).Column
  arr = [a1].CurrentRegion.Resize(, 2 * cnt)
  brr = arr
  For i = 1 To cnt
    dic(LCase(arr(1, i))) = i
  Next
  For j = 1 To cnt
    t = LCase(brr(2, j))
    If Len(t) Then
      If dic.exists(t) Then p = dic(t) Else cnt = cnt + 1: p = cnt
      For i = 2 To UBound(arr, 1)
        arr(i, p) = brr(i, j)
      Next
      If arr(1, j) <> arr(2, j) Then
        For i = 2 To UBound(arr, 1)
          arr(i, j) = vbNullString
        Next
      End If
    End If
  Next
  [a1].Resize(UBound(arr, 1), cnt) = arr
End Sub