[已解决]寻找高手 分支显示世袭表

世袭表.zip (16.97 KB, 下载次数: 123)

2014-8-12 11:02 上传

点击文件名下载附件
如附件所示原文件，想通过VBA实现一个功能。即我在表格sheet1中任选一个人名，然后点击一个控件按钮，即可新建另一个工作簿或者工作表，把所选单元格的人的所有后代列出来（他兄弟的后代就不要显示了），同时，要求他的上几代也只显示他的父亲、爷爷……（不要显示他的伯伯叔叔之类）。首行标题依然存在。
例如：选择f43单元格“世潮”，点击控件按钮后，VBA应显示的结果如sheel2所示。

说明：附件文件是不完整的世袭表，后期还会以插入整行的形式予以增加内容，在编写VBA的时候需要考虑到这点。


考虑了好几天，也不知道这个VBA怎么编，还请高手请教！

最佳答案

月排行榜 / 总排行榜

xdragon

2014-8-12 18:01

1. Sub search()
   
2.    Dim v$, arr, i&, j%, irow&, icol%, re(), st&, c%
   
3.    v = ActiveCell.Value
   
4.    If Len(Trim(v)) = 0 Then MsgBox "请选择一个正确的人名": Exit Sub
   
5.    irow = ActiveCell.Row
   
6.    icol = ActiveCell.Column
   
7.    arr = Range("A1").CurrentRegion.Value
   
8.    ReDim re(1 To 10000, 1 To UBound(arr, 2))
   
9.    '上几代的人名
   
10.    st = irow
    
11.    For j = icol To 1 Step -1
    
12.       For i = st To 2 Step -1
    
13.          If arr(i, j) <> "" Then
    
14.             re(j, j) = arr(i, j)
    
15.             st = i - 1
    
16.             Exit For
    
17.          End If
    
18.       Next
    
19.    Next
    
20.    '后代的人名
    
21.    st = icol
    
22.    For i = irow + 1 To UBound(arr)
    
23.       If arr(i, icol) = "" Then
    
24.          c = c + 1
    
25.          For j = icol + 1 To UBound(arr, 2)
    
26.             If arr(i, j) <> "" Then re(icol + c, j) = arr(i, j)
    
27.          Next
    
28.       Else
    
29.          Exit For
    
30.       End If
    
31.    Next
    
32.    If Sheets.Count = 1 Then Sheets.Add , Sheets(1)
    
33.    Sheets(2).Cells.Clear
    
34.    Sheets(2).Range("A1").Resize(1, UBound(arr, 2)) = Sheet1.Rows(1).Resize(1, Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column).Value
    
35.    Sheets(2).Range("A2").Resize(icol + c, UBound(re, 2)) = re
    
36. End Sub

复制代码

你没说会没有sheet2啊，哈哈

跳转到最佳答案楼层

yangyangzhifeng

试试看

1. Sub TEST()
   
2.     Dim ar, i&, j&, k&, r&, c&, br()
   
3.     r = ActiveCell.Row: c = ActiveCell.Column
   
4.     If ActiveCell = "" Then MsgBox "没有选定任何人！": Exit Sub
   
5.     ar = Sheet1.Range("a1").CurrentRegion
   
6.     ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
7.     For j = 1 To UBound(ar, 2)
   
8.         br(1, j) = ar(1, j)
   
9.     Next
   
10.     k = 1
    
11.     '列出所有后代
    
12.     Do
    
13.         If ar(r + k, c) <> "" Then Exit Do
    
14.         k = k + 1
    
15.     Loop
    
16.     For i = r To r + k - 1
    
17.         For j = c To UBound(ar, 2)
    
18.             br(i, j) = ar(i, j)
    
19.         Next
    
20.     Next
    
21.     '列出直系祖先
    
22.     k = r - 1
    
23.     For j = c To 2 Step -1
    
24.         For i = k To 1 Step -1
    
25.             If ar(i, j) = "" And ar(i, j - 1) <> "" Then
    
26.                 br(i, j - 1) = ar(i, j - 1)
    
27.                 k = i - 1
    
28.                 Exit For
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     '输出及整理
    
33.     With Sheet2
    
34.         .Cells.Clear
    
35.         .Range("a1").Resize(UBound(br), UBound(ar, 2)) = br
    
36.         For i = .UsedRange.Rows.Count + 1 To 1 Step -1
    
37.             If WorksheetFunction.CountA(.Rows(i)) = 0 Then .Rows(i).Delete
    
38.         Next
    
39.          For j = .UsedRange.Columns.Count + 1 To 1 Step -1
    
40.             If WorksheetFunction.CountA(.Columns(j)) = 1 Then .Columns(j).Delete
    
41.         Next
    
42.     End With
    
43. End Sub
    

复制代码

yangyangzhifeng

请见附件 世袭表.rar (19.57 KB, 下载次数: 10)

2014-8-12 14:22 上传

点击文件名下载附件

xdragon

哇，高手就是高手，我研究了半天，才实现一小半，赶紧学学大侠的代码，小妹在此叩谢各位大侠了

发现一个小问题，两位高手都没有注意到，如果原Excel中只有一个工作表，并没有sheet2，代码运行会出错

xdragon

1. Sub search()
   
2.    Dim v$, arr, i&, j%, irow&, icol%, re(), st&, c%
   
3.    v = ActiveCell.Value
   
4.    If Len(Trim(v)) = 0 Then MsgBox "请选择一个正确的人名": Exit Sub
   
5.    irow = ActiveCell.Row
   
6.    icol = ActiveCell.Column
   
7.    arr = Range("A1").CurrentRegion.Value
   
8.    ReDim re(1 To 10000, 1 To UBound(arr, 2))
   
9.    '上几代的人名
   
10.    st = irow
    
11.    For j = icol To 1 Step -1
    
12.       For i = st To 2 Step -1
    
13.          If arr(i, j) <> "" Then
    
14.             re(j, j) = arr(i, j)
    
15.             st = i - 1
    
16.             Exit For
    
17.          End If
    
18.       Next
    
19.    Next
    
20.    '后代的人名
    
21.    st = icol
    
22.    For i = irow + 1 To UBound(arr)
    
23.       If arr(i, icol) = "" Then
    
24.          c = c + 1
    
25.          For j = icol + 1 To UBound(arr, 2)
    
26.             If arr(i, j) <> "" Then re(icol + c, j) = arr(i, j)
    
27.          Next
    
28.       Else
    
29.          Exit For
    
30.       End If
    
31.    Next
    
32.    If Sheets.Count = 1 Then Sheets.Add , Sheets(1)
    
33.    Sheets(2).Cells.Clear
    
34.    Sheets(2).Range("A1").Resize(1, UBound(arr, 2)) = Sheet1.Rows(1).Resize(1, Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column).Value
    
35.    Sheets(2).Range("A2").Resize(icol + c, UBound(re, 2)) = re
    
36. End Sub

复制代码

你没说会没有sheet2啊，哈哈

好用

又发现一个问题，是什么原因导致的呢？

没说清楚，例如当选中J3292单元格，然后运行宏的时候，会报错“下标越界”