提取包含关键字的内容。

ykcbf1100

cqz2022 发表于 2024-1-20 15:41
谢谢

附件供参考。。。

cqz2022

ykcbf1100 发表于 2024-1-20 16:14
附件供参考。。。

运行后报错  我更换了列完整的数据库文件
帮我修正一下 感谢

链接：https://pan.baidu.com/s/1ipvtKUKabN81kfvCAW1uGQ?pwd=j5ip
提取码：j5ip
--来自百度网盘超级会员V10的分享

cqz2022

ykcbf1100 发表于 2024-1-20 16:14
附件供参考。。。

报错 帮我修正一下  谢谢

limonet

关键字：dir+union all

limonet

Sub Limonet()
    Dim Cn As Object, Path$, FileName$, StrSQL$, Rst As Object
    Set Cn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Path = ThisWorkbook.Path & "\数据库\"
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        StrSQL = StrSQL & " Union All Select 修改时间,文件名称,文件路径 From [Excel 12.0;DataBase=" & Path & FileName & "].[第0部分$A2:F] Where 文件名称 Like '%" & Sheet1.Range("B1") & "%'"
        FileName = Dir
    Loop
    Rst.Open Mid(StrSQL, 12), Cn, 1, 3
    If Rst.RecordCount Then
        Sheet3.Copy after:=Sheet1
        ActiveSheet.Name = Sheet1.Range("B1")
        Range("A2").CopyFromRecordset Rst
        Columns("A:C").AutoFit
    End If
End Sub

ykcbf1100

cqz2022 发表于 2024-1-20 16:46
报错 帮我修正一下  谢谢

代码我测试过，没有问题。

蓝桥玄霜

cqz2022 发表于 2024-1-20 11:09
谢谢  这里一直报错

在这一句之前加：If n>0 then Activesheet.[a2].Resize(n,3)=Arr