如何提取不同文件夹里同名excel文档里的信息

rmajly · 发表于 2015-5-19 22:05

本帖最后由 rmajly 于 2015-5-21 16:46 编辑

如何点击“提取并更新数据”按钮后，能自动提取同文件夹里的不同文件夹里同名excel文档里的信息（详见附件），同时自动生成更新时间如表所示。

数据来源均来自“档案M”的excel文档

其中源数据中对应的单元格分别为：sheet1：姓名AJ4，性别（男H1√，女J1√），年龄AJ5+AK5，工号AJ6，档案号 AJ7。Sheet5：个人评价：H9。

a01.zip (103.1 KB, 下载次数: 19)

非常感谢！

旁边的手工录入下表这个功能已经搞好，这个按钮请直接忽视，另外，同文件夹下的不同文件，这里只放了几个实例，实际上可能有60-80个。

rmajly · 发表于 2015-5-20 07:57

旁边的手工录入下表这个功能已经搞好，这个按钮请直接忽视，另外，同文件夹下的不同文件，这里只放了几个实例，实际上可能有60-80个。

liulang0808 · 发表于 2015-5-20 08:14

JingPeng · 发表于 2015-5-20 08:39

不同文件夹下只放一个档案文件的话，可以把档案文件名直接改成员工的名字，然后放同一个文件夹下，这样操作起来好像方便些。

rmajly · 发表于 2015-5-20 14:25

JingPeng 发表于 2015-5-20 08:39
不同文件夹下只放一个档案文件的话，可以把档案文件名直接改成员工的名字，然后放同一个文件夹下，这样操作 ...

那自然，但是现在的文件都已经这么搞好了，再一个个弄更费事啊。多时几十个，几百个

rmajly · 发表于 2015-5-20 20:10

本帖最后由 rmajly 于 2015-5-21 15:21 编辑

我尝试提三个数据试试看，结果出现：“错误1004,不能对合并单元格作部分更改”。不知何故？可我那表格已经固定不好再做更改，必须用到合并单元格，怎么办？做不下去了，求高手

Private Sub 按钮8_单击()
Dim arr()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set cnn = CreateObject("adodb.connection")
[B29:O1000].ClearContents
Mypath = ThisWorkbook.Path & ""
MyName = Dir(Mypath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
ReDim Preserve arr(m)
arr(m) = Mypath & MyName & ""
End If
End If
MyName = Dir
Loop
h = 36
For k = 1 To m
f = Dir(arr(k) & "*.xls")
Do While f > " "
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='excel 8.0;hdr=no';Data Source=" & arr(k) & f
Sql = "select * from [sheet1$aj4:aj4]"
Cells(h, 2).CopyFromRecordset cnn.Execute(Sql)
Sql = "select * from [sheet1$aj5:aj5]"
Cells(h, 4).CopyFromRecordset cnn.Execute(Sql)
Sql = "select * from [sheet1$aj6:aj6]"
Cells(h, 5).CopyFromRecordset cnn.Execute(Sql)
Cells(h, 2) = f
Cells(h, 1) = h - 6
h = h + 1
cnn.Close
f = Dir
Loop
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

a02.zip (106.44 KB, 下载次数: 12)

rmajly · 发表于 2015-5-21 16:02

代码是借别人的，还有四个问题没有解决，请高手再帮帮忙，谢谢！

1、性别不知道怎么提取

2、提取的年龄只有数值，后面怎么再自动加个“岁”字

3、更新的时间用固定格式，比方yyyy-m-d，如图生成的却是“##”

4、如附件002里,合并单元格里就出现问题，如何能解决？

001.zip (130.07 KB, 下载次数: 5)

002.zip (126.1 KB, 下载次数: 5)

opiona · 发表于 2015-5-21 16:49

本帖最后由 opiona 于 2015-5-21 16:59 编辑

完整代码见附件

'*********************************
'******* 北极狐工作室出品 ******
'******* QQ：14885553 ******
'*********************************
Sub Opiona() '//函数实例
Set SH0 = Worksheets("Sheet2")
SH0.Range("B29:R65536").ClearContents
FileArr = FileAllArr(ThisWorkbook.Path, "档案M.xls", ThisWorkbook.Name, False)
For I = 0 To UBound(FileArr)
Set WB = Workbooks.Open(FileArr(I)) '//打开工作簿
SH0.Cells(I + 29, 2) = WB.Worksheets("Sheet1").Range("AJ4")
If InStr(WB.Worksheets("Sheet1").Range("H1"), "√") > 0 Then SH0.Cells(I + 29, 4) = "男"
If InStr(WB.Worksheets("Sheet1").Range("J1"), "√") > 0 Then SH0.Cells(I + 29, 4) = "女"
SH0.Cells(I + 29, 5) = WB.Worksheets("Sheet1").Range("AJ5") & "岁"
SH0.Cells(I + 29, 6) = WB.Worksheets("Sheet1").Range("AJ6")
SH0.Cells(I + 29, 8) = WB.Worksheets("Sheet1").Range("AJ7")
SH0.Cells(I + 29, 12) = Format(Now, "YYYY-MM-DD")
SH0.Cells(I + 29, 15) = WB.Worksheets("Sheet5").Range("H9")
WB.Close False '//保存
Next
End Sub

复制代码

opiona · 发表于 2015-5-21 17:00

aaa.rar (210.58 KB, 下载次数: 41)

rmajly · 发表于 2015-5-21 20:11

opiona 发表于 2015-5-21 17:00

非常感谢，确实很好用！献花权表谢意！

		自动登录	找回密码
密码			免费注册

[求助] 如何提取不同文件夹里同名excel文档里的信息