不打开excel表的情况下引用数据

大头sky

  求助
在不打开表格的情况下提取里面的数据可能吗？
我在每日计划的表格里面输入订单号，后面的简称、数量自动从对应单号的excel表里面提取填入。
见附件  
不胜感激

chaohuahch

供测试

1. Sub FuYun_chaxun1()
   
2. Application.DisplayAlerts = False
   
3. Application.ScreenUpdating = False
   
4. Dim Mypath As String, Myname As String
   
5. Dim Dingdan As String
   
6. Dim nRow As Integer
   
7. Dim wb As Workbook
   
8. ReDim arr(100, 2)
   
9. 
   
10. Set dic = CreateObject("scripting.dictionary")
    
11. 
    
12. Mypath = ThisWorkbook.Path & ""
    
13. Myname = Dir(Mypath & "*.XL*")
    
14. n = 0
    
15. 
    
16. Do While Myname <> ""
    
17.    If Myname <> ThisWorkbook.Name Then
    
18.       Set wb = GetObject(Mypath & Myname)
    
19.    End If
    
20.    
    
21.    With wb.Sheets("包才使用记录书")
    
22.      arr(n, 0) = .Range("z2").Value
    
23.      arr(n, 1) = .Range("f3").Value
    
24.      arr(n, 2) = .Range("z4").Value
    
25.    End With
    
26.    
    
27. Myname = Dir()
    
28. 
    
29. n = n + 1
    
30. Loop
    
31. 
    
32. '把数据放入字典
    
33. 
    
34. For i = 0 To UBound(arr)
    
35.     If arr(i, 0) <> "" Then
    
36.            dic(arr(i, 0)) = Array(arr(i, 1), arr(i, 2))
    
37.     End If
    
38. Next i
    
39. 
    
40. nRow = Range("b" & Rows.Count).End(3).Row
    
41. 
    
42. For i = 7 To nRow
    
43.     Range("b" & i).Offset(0, 1).Resize(1, 2) = dic(Range("b" & i).Value)
    
44. Next i
    
45. 
    
46. 
    
47. Application.DisplayAlerts = True
    
48. Application.ScreenUpdating = True
    
49. 
    
50. End Sub

复制代码

chaohuahch

chaohuahch 发表于 2019-3-20 14:23
供测试

如果你的工作表，超过100个 那么把  ReDim arr(100, 2)  前面的那个100  修改成比你工作表大的值，就可以了

Askinofblue

在每日计划的Sheet1工作表中添加Worksheet_Calculate事件如下：
Private Sub Worksheet_Calculate()
If js = True Then Exit Sub   '当js为true时退出该事件
js = True
s.try Array("tryM"), , Array("FinnallyM")   '在最后需把js设定为false，所以此处使用了try-catch-finnally函数
End Sub

再插入一个模块写入以下代码：
Public js As Boolean   '这个变量用于控制是否执行Worksheet_Calculate事件

Public Function s() As Object  '这一句必须，用于引用SqlCel函数
    Set s = Application.COMAddIns("SqlCelAddIn").Object
End Function

Sub tryM()
On Error GoTo line  '这一句必须用于错误处理
    Dim rn As Range, i As Integer, j As Integer
    If ActiveCell.Column = 3 Then Set rn = ActiveCell.Offset(0, -1)
    If ActiveCell.Column = 2 Then rn = ActiveCell.Offset(0, -1)
    If rn Is Nothing Then Exit Sub
    Dim qax1 As Variant, qax2 As Variant, qax3 As Variant, qaxrow As Variant
    Set qax1 = s.exceltoqax(ThisWorkbook.path & "\20002394.xls", "半成品出入库传票$E4:W17")  '将20002394.xls的部分数据读入qax1数据集
    Set qax2 = s.exceltoqax(ThisWorkbook.path & "\20002365.xls", "半成品出入库传票$E4:W17")  '将20002365.xls的部分数据读入qax2数据集
   
    '*****************此处循环用于将qax2数据集的数据合并到qax1中
    For i = 0 To s.qaxrows(qax2) - 1
        Set qaxrow = s.newrow(qax1)
        For j = 0 To s.qaxcols(qax1) - 1
            Set qaxrow = s.setrowcell(qaxrow, j, s.getcell(qax2, i, j))
        Next j
        Set qax1 = s.addrow(qax1, qaxrow)
    Next i
   
    Set qax3 = s.qaxselect(qax1, "产品CODE='" & rn.Value & "'")   '筛选qax1数据集
    If s.qaxrows(qax2) > 0 Then
        rn.Offset(0, 1).Value = s.getcell(qax2, 0, 6)  '从数据集中取出数据并赋值给单元格
        rn.Offset(0, 3).Value = s.getcell(qax2, 0, 18)
    End If
    Exit Sub
line:  '这一句必须用于错误处理
    s.setErr Err  '这一句必须用于错误处理
End Sub

Sub FinnallyM() '这一句非必须用于最终将js设定为false
js = False
End Sub

以上代码需安装sqlcelfuncs插件才能正常运行。

Askinofblue

其中TryM应该这么写
Sub tryM()
On Error GoTo line  '这一句必须用于错误处理
    Dim rn As Range, i As Integer, j As Integer
    If ActiveCell.Column = 3 Then Set rn = ActiveCell.Offset(0, -1)
    If ActiveCell.Column = 2 Then Set rn = ActiveCell.Offset(-1, 0)
    If rn Is Nothing Then Exit Sub
    Dim qax1 As Variant, qax2 As Variant, qax3 As Variant, qaxrow As Variant
    Set qax1 = s.exceltoqax(ThisWorkbook.path & "\20002394.xls", "半成品出入库传票$E4:W17")  '将20002394.xls的部分数据读入qax1数据集
    Set qax2 = s.exceltoqax(ThisWorkbook.path & "\20002365.xls", "半成品出入库传票$E4:W17")  '将20002365.xls的部分数据读入qax2数据集
   
    '*****************此处循环用于将qax2数据集的数据合并到qax1中
    For i = 0 To s.qaxrows(qax2) - 1
        Set qaxrow = s.newrow(qax1)
        For j = 0 To s.qaxcols(qax1) - 1
            Set qaxrow = s.setrowcell(qaxrow, j, s.getcell(qax2, i, j))
        Next j
        Set qax1 = s.addrow(qax1, qaxrow)
    Next i
   
    Set qax3 = s.qaxselect(qax1, "产品CODE='" & rn.Value & "'")   '筛选qax1数据集
    If s.qaxrows(qax2) > 0 Then
        rn.Offset(0, 1).Value = s.getcell(qax2, 0, 6)  '从数据集中取出数据并赋值给单元格
        rn.Offset(0, 3).Value = s.getcell(qax2, 0, 18)
    End If
    Exit Sub
line:  '这一句必须用于错误处理
    s.setErr Err  '这一句必须用于错误处理
End Sub