求公式转换列表方式

hmcz

求公式转换列表方式.rar (9.56 KB, 下载次数: 4)

2017-12-18 22:34 上传

点击文件名下载附件
求公式转换列表方式

附件求公式解决。谢谢！目的：村名剔除重复的重新列表，村id也一样对应出来，然后是上表中有活动村部的日期列表成横排方式，可增加列方式显示，每个村有多天活动只填写一行就行。
构思第一步把上表提取去除重复的村名、id对应排序，第二部把活动日期改成横排实现，如果能做成一个格子最好，不行就横排实现，如果有3天活动，就横排3列。可以实现吗？

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a3:d" & r)
   
9.     m = 0
   
10.     For i = 1 To UBound(arr)
    
11.       If Not d.exists(arr(i, 3)) Then
    
12.         m = m + 1
    
13.         ReDim brr(1 To 4)
    
14.         brr(1) = m
    
15.         brr(2) = arr(i, 2)
    
16.         brr(3) = arr(i, 3)
    
17.         Set brr(4) = CreateObject("scripting.dictionary")
    
18.       Else
    
19.         brr = d(arr(i, 3))
    
20.       End If
    
21.       brr(4)(arr(i, 4)) = ""
    
22.       d(arr(i, 3)) = brr
    
23.     Next
    
24.   End With
    
25.   For Each aa In d.keys
    
26.     m = m + 1
    
27.     brr = d(aa)
    
28.     ss = ""
    
29.     kk = brr(4).keys
    
30.     ReDim drr(1 To 2)
    
31.     drr(1) = kk(0)
    
32.     drr(2) = kk(0)
    
33.     For j = 1 To UBound(kk)
    
34.       If drr(2) + 1 = kk(j) Then
    
35.         drr(2) = kk(j)
    
36.       Else
    
37.         If drr(1) = drr(2) Then
    
38.           ss = ss & "," & Format(drr(1), "m月d日")
    
39.         Else
    
40.           ss = ss & "," & Format(drr(1), "m月d日") & "-" & Format(drr(2), "d日")
    
41.         End If
    
42.         drr(1) = kk(j)
    
43.         drr(2) = kk(j)
    
44.       End If
    
45.     Next
    
46.     If drr(1) = drr(2) Then
    
47.       ss = ss & "," & Format(drr(1), "m月d日")
    
48.     Else
    
49.       ss = ss & "," & Format(drr(1), "m月d日") & "-" & Format(drr(2), "d日")
    
50.     End If
    
51.     brr(4) = Mid(ss, 2)
    
52.     d(aa) = brr
    
53.   Next
    
54.   With Worksheets("sheet2")
    
55.     .UsedRange.Offset(2, 0).Clear
    
56.     .Range("a3").Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
    
57.   End With
    
58. End Sub
    

复制代码

chxw68

结果在Sheet2中。

hmcz

谢谢老师指点