[已解决]想在现有程序上增加”区域“条件，把区域提取出来，求帮忙解决

xztzd@126.com

如题，详见附表，求各位大神帮忙！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-19 14:20

不好意思，点错了个附件。

跳转到最佳答案楼层

fjmxwrs

什么也没写，不知道你要做的是什么，区域是什么?

grf1973

考虑到名字中的空格去掉，代码如下。

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     brr = Sheet3.[a1].CurrentRegion
   
5.     ReDim crr(1 To UBound(arr) + UBound(brr), 1 To UBound(arr, 2) + UBound(brr, 2))
   
6.    
   
7.     crr(1, 1) = "姓名"
   
8.     For i = 2 To UBound(arr, 2)
   
9.         crr(1, i) = Sheet2.Name & "-" & arr(1, i)
   
10.     Next
    
11.     For j = 2 To UBound(brr, 2)
    
12.         crr(1, i + j - 2) = Sheet3.Name & "-" & brr(1, j)
    
13.     Next
    
14.    
    
15.     For i = 2 To UBound(arr)
    
16.         crr(i, 1) = Replace(arr(i, 1), " ", "")
    
17.         d(crr(i, 1)) = i
    
18.         For j = 2 To UBound(arr, 2)
    
19.             crr(i, j) = arr(i, j)
    
20.         Next
    
21.     Next
    
22.    
    
23.     For k = 2 To UBound(brr)
    
24.         x = Replace(brr(k, 1), " ", "")
    
25.         If d.exists(x) Then p = d(x) Else p = i: i = i + 1
    
26.         crr(p, 1) = x
    
27.         For jj = 2 To UBound(brr, 2)
    
28.             crr(p, j + jj - 2) = brr(k, jj)
    
29.         Next
    
30.     Next
    
31.    
    
32.     [a1].Resize(i, j + jj - 2) = crr
    
33. End Sub
    

复制代码

grf1973

请看附件。

grf1973

不好意思，点错了个附件。