查找写值

sampsonpon

查找写值，详细如下：

demonimissyou

参与一下……………………

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2025.3.12
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set ws = ThisWorkbook
   
5.     p = ws.Path & ""
   
6.     rq = CDate(ws.Sheets("汇总").[g1].Value)
   
7.     On Error Resume Next
   
8.     Dim tm: tm = Timer
   
9.     ReDim brr(1 To 10 ^ 5, 1 To 1)
   
10.     For Each f In fso.GetFolder(p).Files
    
11.         If LCase$(f.Name) Like "*.xls*" Then
    
12.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 arr = wb.Sheets("自制来货时间").UsedRange
    
15.                 wb.Close 0
    
16.                 For i = 2 To UBound(arr)
    
17.                     If CDate(arr(i, 2)) = rq Then
    
18.                         m = m + 1
    
19.                         brr(m, 1) = arr(i, 1)
    
20.                     End If
    
21.                 Next
    
22.             End If
    
23.         End If
    
24.     Next
    
25.     With Sheets("HU_Wtyor")
    
26.         .[q2].Resize(10000, 1) = Empty
    
27.         .[q2].Resize(m, 1) = brr
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
31. End Sub
    
32. 
    

复制代码

sampsonpon

ykcbf1100 发表于 2025-3-12 15:58

草爷，这里表达是不是如果同一路径下有很多个*.xls*工作簿都要检索一遍呢？
其实它这里只有两个工作簿：自制HU扫描时间记录.xlsm、自制HU扫描时间记录-lens.xlsm
是不是要再缩小一下范围呢？

shiruiqiang

If InStr(f.Name, 自制HU扫描时间记录) Then

gwjkkkkk

Option Explicit
Sub test1()
    Dim j&, cnn As Object, rst As Object, strSQL$, strCnn$, strJoin$, strPath$, strFileName$
   
    Application.ScreenUpdating = False
   
    strJoin = "Excel 12.0;HDR=YES;IMEX=0;Database="
    Select Case Application.Version * 1
        Case Is <= 11
            strJoin = Replace(strJoin, "12.0;", "8.0;")
            strCnn = "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=0'"
        Case Is >= 12
            strCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES;IMEX=0'"
    End Select

    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            strSQL = strSQL & " UNION ALL SELECT * FROM [" & strJoin & strPath & strFileName & "].[$A1:B]"
        End If
        strFileName = Dir
    Loop
   
    If Len(strSQL) = 0 Then
        Application.ScreenUpdating = True: MsgBox "未找到待汇总文件!", vbCritical: Exit Sub
    Else
        strSQL = "SELECT 扫描号码 FROM(" & Mid(strSQL, 12) & ") WHERE 日期=#" & Worksheets(2).[G1].Value & "#"
        
    End If
        
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open strCnn
    Set rst = cnn.Execute(strSQL)
   
    With ThisWorkbook.Sheets(1)
        .Columns("G").Clear
        .Range("Q2").CopyFromRecordset rst
        .Activate
    End With
   
    rst.Close: cnn.Close
    Set rst = Nothing: Set cnn = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

代码审核中，请参考图片。。。

sampsonpon

gwjkkkkk 发表于 2025-3-12 19:31
Option Explicit
Sub test1()
    Dim j&, cnn As Object, rst As Object, strSQL$, strCnn$, strJoin$,  ...

这是SQL代码还是VBA代码？

ykcbf1100

sampsonpon 发表于 2025-3-12 16:59
草爷，这里表达是不是如果同一路径下有很多个*.xls*工作簿都要检索一遍呢？
其实它这里只有两个工作 ...

没什么关系的，遍历文件，也只是遍历二个文件而已。如果你加上判断，那反而多花时间了，除非那个文件夹中还有其它文件存在。