[已解决]问题：提取字段和时间并整理相同列标题数据

丹青

提取字段和时间并整理相同列标题数据，具体要求详见附件，拜托了，在此先行谢过

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-17 13:33

1. Sub tt()
   
2.     arr = Sheet1.Range("a1:a" & Sheet1.[a65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 1000)
   
4.     brr(1, 1) = "的中间处理过程"
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 1)
   
8.         xrr = Split(x, ";")
   
9.         a = InStr(xrr(0), ":")
   
10.         If a > 0 Then
    
11.             brr(i, 1) = Left(x, a - 8)
    
12.             xrr(0) = Mid(xrr(0), a + 1)
    
13.         End If
    
14.         
    
15.         For k = 0 To UBound(xrr)
    
16.             a = InStr(xrr(k), ":")
    
17.             If a > 1 Then
    
18.                 gc = Left(xrr(k), a - 1)  '过程
    
19.                 If Not d.exists(gc) Then
    
20.                     c = c + 1
    
21.                     d(gc) = c + 1
    
22.                     brr(1, d(gc)) = gc
    
23.                 End If
    
24.                 brr(i, d(gc)) = Mid(xrr(k), a + 1)
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     Sheet2.Cells.ClearContents
    
29.     Sheet2.[b1].Resize(UBound(arr), c) = brr
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     arr = Sheet1.Range("a1:a" & Sheet1.[a65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 1000)
   
4.     brr(1, 1) = "的中间处理过程"
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 1)
   
8.         xrr = Split(x, ";")
   
9.         a = InStr(xrr(0), ":")
   
10.         If a > 0 Then
    
11.             brr(i, 1) = Left(x, a - 8)
    
12.             xrr(0) = Mid(xrr(0), a + 1)
    
13.         End If
    
14.         
    
15.         For k = 0 To UBound(xrr)
    
16.             a = InStr(xrr(k), ":")
    
17.             If a > 1 Then
    
18.                 gc = Left(xrr(k), a - 1)  '过程
    
19.                 If Not d.exists(gc) Then
    
20.                     c = c + 1
    
21.                     d(gc) = c + 1
    
22.                     brr(1, d(gc)) = gc
    
23.                 End If
    
24.                 brr(i, d(gc)) = Mid(xrr(k), a + 1)
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     Sheet2.Cells.ClearContents
    
29.     Sheet2.[b1].Resize(UBound(arr), c) = brr
    
30. End Sub
    

复制代码

grf1973

里面好多不规则的。建议要提取的列名人工固定。

丹青

grf1973 发表于 2015-11-17 13:34
里面好多不规则的。建议要提取的列名人工固定。

里面的中间过程有点随机的感觉，所以还真不好固定下来，感谢老师的帮助，后期有问题再咨询您，再次感谢