获取多个表格数据

yksoft

根据代码 获取多个表格数据  有请大神帮助   非常感激

longwin

Sub test()
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange.Value
dm = CStr([a1].Value)
'数据段自第三行开始
For i = 3 To UBound(arr)
If arr(i, 1) <> "" Then rq = arr(i, 1)
    If CStr(arr(i, 3)) = dm Then
        d(rq) = i
    End If
Next
ReDim brr(1 To d.Count + 1, 1 To 7)
For j = 1 To UBound(brr, 2)
    brr(1, j) = arr(3, j)
Next
brr(1, 1) = "日期"
m = 1
For Each Key In d.keys
    m = m + 1
    brr(m, 1) = Key
    For j = 2 To UBound(brr, 2)
        brr(m, j) = arr(Val(d(Key)), j)
    Next
Next

[I3].Resize(UBound(brr), UBound(brr, 2)) = brr

End Sub

Qs18

1. Sub qs()
   
2. Dim rng As Range
   
3. With Sheet1
   
4.     s = .[a1]
   
5.    For Each sht In Sheets
   
6.     If sht.Name <> "Sheet5" Then
   
7.         Set rng = sht.Cells.Find(s)
   
8.         If Not rng Is Nothing Then
   
9.         k = .Cells(Rows.Count, 2).End(3).Row + 2
   
10.         sht.UsedRange.Copy .Range("a" & k)
    
11.         End If
    
12.     End If
    
13.    Next
    
14. End With
    
15. End Sub

复制代码

Qs18

试试........

gwjkkkkk

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:G" & .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

Qs18

试试.............

gwjkkkkk

请参考。。。。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

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

yksoft

Qs18 发表于 2024-10-2 18:00
试试.............

如果A列 有30个ID  从A1排到A30   B到K给A1用   J到S  给A2用   每一个用10列  可以吗 大神