根据单元格内的文件名提取文件中内容

lfspecter

cjc209 发表于 2021-1-19 11:36
你的是有空白表存在

是的，录入的数据有输入错误，我也发现了。

lfspecter

cjc209 发表于 2021-1-19 11:37
数据规范 sql查询最快  如果不规范 sql会出错 或者不准确的

这个就是基础数据规范的重要性，本来计划用Access+Excel来实现的，但是工程有点大，数据的不一致性。
暂时先这样搞一下，有时间重新帮他们规划基础数据再想办法吧。

xiangbaoan

cjc209 发表于 2021-1-19 11:44
如果容错 数据错在哪里就更不知道了

此时的错误，我猜  只可能是L11及以下没内容  导致，所以容错可行。不容错也可如下（个人做法）：
Option Explicit

Sub test()
  Dim Cn As Object, Rs As Object, Sq$, p$, f$, ar, br, cr, i&
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set Cn = CreateObject("ADODB.Connection")
  p = ThisWorkbook.Path & "\"
  ar = Range("E2:E" & Cells(Rows.Count, 5).End(xlUp).Row)
  br = Range("L2:L" & Cells(Rows.Count, 5).End(xlUp).Row)
  Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
  For i = 1 To UBound(ar)
    f = Dir(p & ar(i, 1) & ".xls?")
   If Len(f) Then
      Sq = "SELECT f1 FROM [Excel 12.0;HDR=no;Database=" & p & f & "].[$l11:l] WHERE LEN(f1)"
      Set Rs = Cn.Execute(Sq)
      If Not Rs.EOF And Not Rs.BOF Then
        cr = Rs.GetRows
        If TypeName((cr(0, UBound(cr, 2)))) <> "String" Then br(i, 1) = Val(br(i, 1)) + cr(0, UBound(cr, 2))
      End If
    End If
  Next
  Range("L2").Resize(i - 1) = br
  Cn.Close
  Set Cn = Nothing
  Set Rs = Nothing
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Beep
End Sub

xiangbaoan

cjc209 发表于 2021-1-19 11:44
如果容错 数据错在哪里就更不知道了

当确认错误所在，且不影响结果，为什么不可？有时利用错误也是明智选择。

xiangbaoan

lfspecter 发表于 2021-1-19 11:28
可以正常运行下来，速度还可以。
感谢。

lfspecter

xiangbaoan 发表于 2021-1-19 12:50

鼠标选择，或者输入区域，哪个方便都可以

xiangbaoan

lfspecter 发表于 2021-1-19 14:11
鼠标选择，或者输入区域，哪个方便都可以

test.rar (827 Bytes, 下载次数: 16)

2021-1-19 14:50 上传

点击文件名下载附件
仅测试

lfspecter

xiangbaoan 发表于 2021-1-19 14:51

1. Sub test()
   
2.   Dim Cn As Object, Sq$, p$, f$, ar, br, cr, i&
   
3.   Application.ScreenUpdating = False
   
4.   Application.DisplayAlerts = False
   
5.   Set Cn = CreateObject("ADODB.Connection")
   
6.   p = "\\CNTXQM0NSIFSN01\Die Cut\Manufacturing\物料控制_陈英征\刀具管理\子目录"
   
7.   ar = Range("a2:a" & Cells(Rows.Count, 5).End(xlUp).Row)
   
8.   br = Range("b2:b" & Cells(Rows.Count, 5).End(xlUp).Row)
   
9.   Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
   
10.   For i = 1 To UBound(ar)
    
11.     f = Dir(p & ar(i, 1) & ".xls?")
    
12.     If Len(f) Then
    
13.       Sq = "SELECT f1 FROM [Excel 12.0;HDR=no;Database=" & p & f & "].[$l11:l] WHERE LEN(f1)"
    
14.       cr = Cn.Execute(Sq).GetRows
    
15.       On Error Resume Next
    
16.       If TypeName((cr(0, UBound(cr, 2)))) <> "String" Then br(i, 1) = Val(br(i, 1)) + cr(0, UBound(cr, 2))
    
17.     End If
    
18.   Next
    
19.   Range("b2").Resize(i - 1) = br
    
20.   Cn.Close
    
21.   Set Cn = Nothing
    
22.   Application.DisplayAlerts = True
    
23.   Application.ScreenUpdating = True
    
24.   Beep
    
25. End Sub

复制代码

将原来的E列数据复制到A列，查找结果写入B列，没改成功

xiangbaoan

lfspecter 发表于 2021-1-20 08:43
将原来的E列数据复制到A列，查找结果写入B列，没改成功

test.rar (791 Bytes, 下载次数: 15)

2021-1-20 10:19 上传

点击文件名下载附件

lfspecter

xiangbaoan 发表于 2021-1-20 10:20

AAA.zip (17.24 KB, 下载次数: 4)

2023-1-3 08:23 上传

点击文件名下载附件

提取文件夹内所有文件最新内容，说明见附件