[已解决]求个代码把更新时间为3-19的提出来，有人会吗？

tzjx200521

Sub 提取a()
Dim sht As Worksheet, hb_sht As Worksheet, rg As Range, n As Integer
Dim add
n = 1
Application.ScreenUpdating = False
On Error Resume Next
Set hb_sht = Sheets("合并含a")
For Each sht In Sheets
    If sht.Name <> "合并含a" Then
        Set rg = sht.Range("A:A").Find("a", , , xlWhole)
        If Not rg Is Nothing Then
            add = rg.Address
            Do
            rg.EntireRow.Resize(3).Copy hb_sht.Range("A" & n)
            n = n + 4
            Set rg = sht.Range("A:A").FindNext(rg)
            Loop Until rg.Address = add
        End If
    End If
Next
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
可以在这个代码上改

最佳答案

月排行榜 / 总排行榜

bb75308973

2012-3-22 17:26

这个代码好熟悉
这个附件里的内容好熟悉
朋友,好像这是第三次帮你喽
只要改动一点点就好了
这单元格复制过去会显示为0
想要0显示为空可以写代码的不过这里不写了
你只要用查找替换功能查找0的单元格替换为空就好了

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("提取时间为3月19日") '这里改了
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "提取时间为3月19日" Then '这里改
   
10.         Set rg = sht.Range("A:A").Find("3-19", , , xlPart) '这里改
    
11.         If Not rg Is Nothing Then
    
12.             add = rg.Address
    
13.             Do
    
14.             rg.Offset(-1).EntireRow.Resize(4).Copy hb_sht.Range("A" & n) '这里改
    
15.             n = n + 5
    
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

复制代码

跳转到最佳答案楼层

bb75308973

这个代码好熟悉
这个附件里的内容好熟悉
朋友,好像这是第三次帮你喽
只要改动一点点就好了
这单元格复制过去会显示为0
想要0显示为空可以写代码的不过这里不写了
你只要用查找替换功能查找0的单元格替换为空就好了

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("提取时间为3月19日") '这里改了
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "提取时间为3月19日" Then '这里改
   
10.         Set rg = sht.Range("A:A").Find("3-19", , , xlPart) '这里改
    
11.         If Not rg Is Nothing Then
    
12.             add = rg.Address
    
13.             Do
    
14.             rg.Offset(-1).EntireRow.Resize(4).Copy hb_sht.Range("A" & n) '这里改
    
15.             n = n + 5
    
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

复制代码

tzjx200521

哈哈谢谢你啊。。。。老师  多次麻烦你。。。