[已解决]求老师帮忙求个VB代码

tzjx200521

如附件要求。。能把附件中的A列单元格中数值为a的选出来，放在最后个表中，，求解。。。

最佳答案

月排行榜 / 总排行榜

bb75308973

2012-3-20 22:30

看看吧,个人测试没问题,你测试下

1. Sub 提取a()
   
2. Dim sht As Worksheet, hb_sht As Worksheet, rg As Range, n As Integer
   
3. Dim add
   
4. n = 1
   
5. Application.ScreenUpdating = False
   
6. On Error Resume Next
   
7. Set hb_sht = Sheets("合并含a")
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "合并含a" Then
   
10.         Set rg = sht.Range("A:A").Find("a", , , xlWhole)
    
11.         If Not rg Is Nothing Then
    
12.             add = rg.Address
    
13.             Do
    
14.             rg.EntireRow.Resize(3).Copy hb_sht.Range("A" & n)
    
15.             n = n + 4
    
16.             Set rg = sht.Range("A:A").FindNext(rg)
    
17.             Loop Until rg.Address = add
    
18.         End If
    
19.     End If
    
20. Next
    
21. On Error GoTo 0
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

1111 (自动保存的).zip (12.25 KB, 下载次数: 12)

2012-3-20 22:30 上传

点击文件名下载附件

跳转到最佳答案楼层

bb75308973

看看吧,个人测试没问题,你测试下

1. Sub 提取a()
   
2. Dim sht As Worksheet, hb_sht As Worksheet, rg As Range, n As Integer
   
3. Dim add
   
4. n = 1
   
5. Application.ScreenUpdating = False
   
6. On Error Resume Next
   
7. Set hb_sht = Sheets("合并含a")
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "合并含a" Then
   
10.         Set rg = sht.Range("A:A").Find("a", , , xlWhole)
    
11.         If Not rg Is Nothing Then
    
12.             add = rg.Address
    
13.             Do
    
14.             rg.EntireRow.Resize(3).Copy hb_sht.Range("A" & n)
    
15.             n = n + 4
    
16.             Set rg = sht.Range("A:A").FindNext(rg)
    
17.             Loop Until rg.Address = add
    
18.         End If
    
19.     End If
    
20. Next
    
21. On Error GoTo 0
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

1111 (自动保存的).zip (12.25 KB, 下载次数: 12)

2012-3-20 22:30 上传

点击文件名下载附件