不打开工作簿取数

黑山上的鹰

文件夹中有名为“2013基数”、“2014基数”、“2015基数”、“2016基数”的excel工作簿（简称数据源），每个工作簿有“工作簿名称+月”（201301、201302等）的工作表，工具工作簿中有“2013基数”、“2014基数”、“2015基数”、“2016基数”工作表，其中g3:d3单元格区域代表当年的月份，与数据源工作簿中的工作表名称相同。
求助：以社保号为关键字，将数据源工作簿中每个工作表的数据（g列）导入工具工作簿。对应关系为：数据源工作簿名称=工具工作簿中的工作表名称，数据源工作簿中每个工作表的社保号=工具工作簿中的对应表的社保号，数据源工作簿中每个工作表名=工具工作簿中的对应表的g3:d3单元格区域。
如何达成，请帮助，谢谢！！！
表述可能不清楚，敬请谅解。
新建文件夹 - 副本.rar (40.89 KB, 下载次数: 23)

2016-6-21 08:58 上传

点击文件名下载附件

自己编了一段，取不了数，详见窗体中的“导入”，求解，谢谢

小花鹿

你这附件做得不规范.....................................................................................................

黑山上的鹰

新建文件夹 - 副本.rar (40.89 KB, 下载次数: 36)

2016-6-21 09:01 上传

点击文件名下载附件

重新整附件上传，详见窗体中的导入

opiona

参考：http://club.excelhome.net/forum-2-1.html

黑山上的鹰

opiona 发表于 2016-6-21 10:19
参考：http://club.excelhome.net/forum-2-1.html

谢谢，链接不到呀

魂断蓝桥

Sub a()
Dim cnn As Object, rs As Object, SQL$, Mypath$, MyName$, arr
Dim i%, j As Byte, d, x%, y%, m%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Mypath = ThisWorkbook.Path & "\"
MyName = Dir(Mypath & "*.xls")
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & Mypath & MyName
        For j = 1 To 3
            SQL = "select F1,F2,""" & Replace(MyName, "基数.xls", "") & Format(j, "00") & """ from [" & Replace(MyName, "基数.xls", "") & Format(j, "00") & "$f4:g] where F1 IS NOT NULL"
            Set rs = cnn.Execute(SQL)
            arr = rs.getRows
                    For m = 0 To UBound(arr, 2)
                        d(arr(0, m) & arr(2, m)) = arr(1, m)
                    Next
        Next
    End If
    MyName = Dir()
Loop
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
For j = 1 To Sheets.Count
    arr = Sheets(j).Range("f3:r" & Sheets(j).Range("f9999").End(3).Row)
    For x = 2 To UBound(arr)
        For y = 2 To UBound(arr, 2)
            arr(x, y) = d(arr(x, 1) & arr(1, y))
        Next
    Next
        Sheets(j).[f3].Resize(UBound(arr), UBound(arr, 2)) = arr
Next
Set d = Nothing
Application.ScreenUpdating = True
End Sub

黑山上的鹰

魂断蓝桥 发表于 2016-6-21 12:39
Sub a()
Dim cnn As Object, rs As Object, SQL$, Mypath$, MyName$, arr
Dim i%, j As Byte, d, x%, y%, ...

谢谢蓝桥老师，需要仔细学习一下。

goway

1. Private Sub CommandButton3_Click()
   
2. Dim myStr$
   
3. myStr = ComboBox1.Text & "基数.xls"
   
4. lqxs (myStr)
   
5. End Sub
   
6. Sub lqxs(myFilename As String)
   
7.     Dim  myPath$, i&, myStr$, sheetName$, myRow%, myColumn%
   
8.     myPath = ThisWorkbook.Path & "" & myFilename
   
9. 
   
10.     Set wb = GetObject(myPath)
    
11.    
    
12.     sheetName = Replace(myFilename, ".xls", "")
    
13.     For i = 0 To wb.Sheets.Count - 1
    
14.         myStr = wb.Sheets(i + 1).Name
    
15.         With wb
    
16.             For j = 1 To Sheets(sheetName).Range("F65536").End(xlUp).Row
    
17.                 For k = 1 To .Sheets(myStr).Range("F65536").End(xlUp).Row
    
18.                     If .Sheets(myStr).Range("F" & k).Value = Sheets(sheetName).Range("F" & j).Value Then
    
19.                         myRow = Sheets(sheetName).Range("F" & j).Row
    
20.                         myColumn = Sheets(sheetName).Range("F" & j).Column + 1 + i
    
21.                         Sheets(sheetName).Cells(myRow, myColumn).Value = .Sheets(myStr).Range("G" & k).Value
    
22.                     End If
    
23.                 Next
    
24.             Next
    
25.         End With
    
26.     Next
    
27.     'windows(wb.name).visible=true  ''关闭工作簿之前修改可见性
    
28.     wb.Close False  'true保存改变
    
29. 
    
30. End Sub
    

复制代码

学习下魂断蓝桥的代码，尝试用GetObject也写了个。

黑山上的鹰

goway 发表于 2016-6-22 08:32
学习下魂断蓝桥的代码，尝试用GetObject也写了个。

两种不同发生，拿来对比学习，谢谢，非常感谢。

LMY123

arr = rs.getRows