多表多次循环查找

yksoft

单个查找可以  但要多次查找再分位置  需要大神指点帮助

明天会更好zj

单个了都可以，多个自己不会想？？？白嫖？

quqiyuan

多了个循环，其实想想也能根据前面的做得了，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Dim sh As Worksheet, rng As Range, rg As Range
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet5")
    s = sht.[a1:a30]
    sht.[b3:zz1000000].ClearContents
    For i = 1 To 30
        r = 3
        For Each sh In wb.Sheets
            If sh.Name <> sht.Name Then
                Set rng = sh.UsedRange.Find(s(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                If Not rng Is Nothing Then
                    With sht
                        rng.CurrentRegion.Copy .Cells(r, 2 + 10 * (i - 1))
                        r = .Cells(.Rows.Count, 2 + 10 * (i - 1)).End(3).Row + 2
                    End With
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
    Beep
End Sub

yksoft

quqiyuan 发表于 2024-10-2 20:37
多了个循环，其实想想也能根据前面的做得了，仅供参考。。。

非常感谢大神   

quqiyuan

你有些表格第一列不齐全，有空，造成有些覆盖了，你改一下这个数字。。。
本来是2，改成3就可以了

yksoft

quqiyuan 发表于 2024-10-2 20:52
你有些表格第一列不齐全，有空，造成有些覆盖了，你改一下这个数字。。。
本来是2，改成3就可以了

收到谢谢  

yksoft

quqiyuan 发表于 2024-10-2 20:52
你有些表格第一列不齐全，有空，造成有些覆盖了，你改一下这个数字。。。
本来是2，改成3就可以了

Option Explicit
Sub TEST2()
    Dim r&, wks As Worksheet, strFind$, rng As Range, rngFind As Range
   
    Application.ScreenUpdating = False
   
    With Worksheets(1)
        strFind = .[a1].Value
        .Range("A3:H" & .Rows.Count).Clear
        For Each wks In Worksheets
            If wks.Name <> .Name Then
                Set rng = wks.[a1].CurrentRegion
                Set rngFind = rng.Find(strFind, , , xlWhole)
                If Not rngFind Is Nothing Then
                    r = .Cells(.Rows.Count, "G").End(xlUp).Row
                    r = IIf(r = 1, 3, r + 2)
                    .Cells(r, 1).Value = wks.Name
                    rng.Copy .Cells(r, 2)
                End If
            End If
        Next
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

我看到的代码不一样啊

quqiyuan

yksoft 发表于 2024-10-2 21:10
Option Explicit
Sub TEST2()
    Dim r&, wks As Worksheet, strFind$, rng As Range, rngFind As Ran ...

这个是你原文件里的，我的在模块1。

yksoft

quqiyuan 发表于 2024-10-2 21:32
这个是你原文件里的，我的在模块1。

收到  谢谢 我看到了