急!如何输入日期，自动得到该日期每个数据表的数据（已解决）

wyshsn

求助：如何输入日期，自动得到该日期每个数据表的数据包括账号信息（每个公司账号一个数据表，用账号末四位数字命名0802,5574,5456,0040,8486,0902）下表是手动输入的示例

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br, i&, j&, r&, dic As Object, wks As Worksheet, iPosCol&, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    With [A1].CurrentRegion
       .Offset(2).ClearContents
       ar = .Resize(10 ^ 3)
    End With
    r = 2
    For i = 2 To UBound(ar, 2): dic(ar(2, i)) = i: Next
   
    For Each wks In Sheets
      If wks.Name <> ActiveSheet.Name Then
         With wks
            br = .[A3].CurrentRegion
            For i = 2 To UBound(br)
               If br(i, 1) = [B1] Then
                  r = r + 1
                  ar(r, 1) = .[A1]
                  For j = 1 To UBound(br, 2)
                     vKey = br(1, j)
                     If dic.exists(vKey) Then
                        iPosCol = dic(vKey)
                        ar(r, iPosCol) = br(i, j)
                     End If
                  Next j
               End If
            Next i
         End With
      End If
    Next
   
    Set dic = Nothing
    [A1].Resize(r, UBound(ar, 2)) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

shiruiqiang

------------------

gwjkkkkk

请楼主参考附件。。。

wyshsn

shiruiqiang 发表于 2023-2-7 21:33
------------------

实现了我想要的功能，高手！非常谢谢！

wyshsn

shiruiqiang 发表于 2023-2-7 21:33
------------------

实现了我想要的功能，高手！非常谢谢！

wyshsn

gwjkkkkk 发表于 2023-2-7 21:34
请楼主参考附件。。。

同样实现了我想要的功能，高手！非常谢谢！

wyshsn

已解决，谢谢两位高手的指点！