如何根据日期条件把相关的数据复制到一个表里面

-建发

亲，麻烦一下各位大神，如何把其他平台相关的数据根据对应日期用VBA复制到图三汇总表里面去？日期每天手动更新，最终效果如下

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br, i&, j&, r&, n&, dic As Object, iPosCol&, wks As Worksheet
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    If Trim([N1]) = "" Then MsgBox "日期为空，请检查！": Exit Sub
   
    With [A1].CurrentRegion
        .Offset(1).Clear
        ar = .Resize(10 ^ 4)
        For i = 1 To UBound(ar, 2): dic(ar(1, i)) = i: Next
        r = 1
    End With
   
    For Each wks In Sheets
        If wks.Name <> "汇总" Then
            br = wks.[A1].CurrentRegion
            n = 0
            For i = 1 To UBound(br, 2)
                If br(1, i) = "日期" Then: n = i: Exit For
            Next i
            If n <> 0 Then
                For i = 2 To UBound(br)
                    If br(i, n) = [N1] Then
                        r = r + 1
                        For j = 1 To UBound(br, 2)
                            If dic.exists(br(1, j)) Then
                                iPosCol = dic(br(1, j))
                                ar(r, iPosCol) = br(i, j)
                            End If
                        Next j
                    End If
                Next i
            End If
        End If
    Next
   
    With [A1].Resize(r, UBound(ar, 2))
        .Columns(2).NumberFormatLocal = "yyyy-m-m"
        .Value = ar
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

-建发

gwjkkkkk 发表于 2023-3-23 18:29
请参考。。。

大佬没办法下载

gwjkkkkk

-建发 发表于 2023-3-23 18:46
大佬没办法下载

将文本文件代码拷入模块，切换到第一个工作表运行。。。

-建发

gwjkkkkk 发表于 2023-3-23 19:13
将文本文件代码拷入模块，切换到第一个工作表运行。。。

多谢大佬，我研究一下