求助老师 VBA大于当天日期筛选出特定行数据保存到新的文件

沈默00

VBA就不写了，365函数来一个

d66191055

limonet 发表于 2024-5-9 11:22
Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")

老师   
这行 报错   Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 xml;Data Source=" & ThisWorkbook.Path & "\" & Date & ".xlsx"
不是一个有效路径

沈默00

日期格式要用标准格式，，，

d66191055

沈默00 发表于 2024-5-9 13:54
VBA就不写了，365函数来一个

老师  
我的想法 是这样的  
新建一个excel  添加 按钮 运行宏  宏的目的是筛选F:/ 样本.excel 将想要的数据另存为一个文件
大概就是这个意思  

d66191055

ykcbf1100 发表于 2024-5-9 11:25
参与一下。。。

老师   你好  
可能是我表述的不清楚  
我的想法 是这样的  
新建一个excel  添加 按钮 运行宏  宏的目的是筛选F:/ 样本.excel中   表1 和 表2中 19列日期大于当天日期数据（只要图号、名称、需求日期、数量、订单日期）单独另存为一个文件
大概就是这个意思  

Qs18

Sub test()
Dim wb As Workbook, wb2 As Workbook, arr, sht As Worksheet
Application.ScreenUpdating = False
Set wb = ThisWorkbook
td = Date
For Each st In wb.Sheets
    st.Activate
    arr = st.Range([a1], Cells(Rows.Count, 29).End(xlUp))
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
      k = 0
    For i = 2 To UBound(arr)
        If arr(i, 19) >= td Then
             k = k + 1
            For j = 1 To UBound(arr, 2)
   
                brr(k, j) = arr(i, j)
            Next j
        End If
    Next
    Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\结果.xlsx")
    Set sht = wb2.Sheets.Add
    sht.Name = st.Name
    For m = 1 To UBound(arr, 2)
        sht.Cells(1, m).Value = arr(1, m)
    Next m
    sht.Range("a2").Resize(k, UBound(brr, 2)) = brr
    wb2.Close (True)
Next
Application.ScreenUpdating = True
End Sub

Qs18

试试   参与一下。  。

d66191055

Qs18 发表于 2024-5-9 14:21
试试   参与一下。  。

老师  可以吧 筛选的结果汇总到一个表格里吗  结果.xlsx 只保留 汇总后的结果  

Qs18

Sub test()
Dim wb As Workbook, wb2 As Workbook, arr, sht As Worksheet
crr = Array("图号", "名称", "需求日期", "数量", "订单日期")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ThisWorkbook
td = Date
For Each st In wb.Sheets
    st.Activate
    arr = st.Range([a1], Cells(Rows.Count, 29).End(xlUp))
    ReDim brr(1 To UBound(arr), 1 To 5)
      k = 0
    For i = 2 To UBound(arr)
        If arr(i, 19) >= td Then
             k = k + 1
                brr(k, 1) = arr(i, 6)
                brr(k, 2) = arr(i, 9)
                brr(k, 3) = arr(i, 19)
                brr(k, 4) = arr(i, 21)
                brr(k, 5) = arr(i, 29)
        End If
    Next
    Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\结果.xlsx")
    Set sht = wb2.Sheets.Add
    sht.Name = st.Name
     sht.Cells(1, 1).Resize(1, 5) = crr
   
    sht.Range("a2").Resize(k, UBound(brr, 2)) = brr
    Columns("A:E").AutoFit
    wb2.Close (True)
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("表1").Activate
End Sub

Qs18

d66191055 发表于 2024-5-9 14:32
老师  可以吧 筛选的结果汇总到一个表格里吗  结果.xlsx 只保留 汇总后的结果

你以什么为依据来汇总