不同表格文件之间的数据获取

lfg0327

各位大师好！！请教一个问题：我为了给单位几百名员工进行年终考核的数据收集。每名员工一个EXCEL表（类似简历表，表格格式完全相同，每个表格是一个单独的EXCEL文件，文件名以员工工号和姓名命名）B1，B2，B3，......，还有一张汇总表A。如何实现不打开每一名员工个人的表，而把每个人的表B1,B2,B3,...中的数据，获取到汇总表A中（汇总表中事先已经保存有每名员工的工号和姓名以及与个人表中的数据项对应的列，每名员工的数据占一行）？

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
遍历文件的资料，用程序打开，关闭文件即可

lfg0327

liulang0808老师您好，我把附件上传，麻烦您看一下，好吗？

lfg0327

麻烦老师看看。谢谢！

LMY123

多薄单表合并

wangxml

1. Option Explicit
   
2. 
   
3. Sub main()
   
4. Call createNewSheet
   
5. Sheets("NewSheet").Rows.ClearContents
   
6. Dim i As Integer
   
7. Dim wbFile As String, wbPath As String
   
8. i = 0
   
9. wbFile = Dir(ThisWorkbook.Path & "" & "*.xlsx")
   
10. Do While wbFile <> "" And wbFile <> ThisWorkbook.Name
    
11.   i = i + 1
    
12.   Dim wbOpen As Workbook, wbNow As Workbook
    
13.   Set wbNow = ThisWorkbook
    
14.   Set wbOpen = Workbooks.Open(ThisWorkbook.Path & "" & wbFile)
    
15.   Call copyDataToALine(i, wbOpen, wbNow)
    
16.   wbOpen.Close savechanges:=False
    
17.   wbFile = Dir
    
18.   Loop
    
19.   Sheets("NewSheet").Columns(4).Delete
    
20.   Sheets("NewSheet").Columns(8).Insert
    
21.   For i = 4 To Sheets("教师").Range("C4").End(xlDown).Row
    
22.    Call copyDataToFacl(i)
    
23.    Next i
    
24. End Sub
    
25. 
    
26. Public Function copyDataToFacl(ByVal iFacl As Integer)
    
27. Dim iRow As Integer
    
28. For iRow = 1 To Sheets("NewSheet").Range("A1").End(xlDown).Row
    
29.   If Sheets("NewSheet").Cells(iRow, 1).Value = Sheets("教师").Cells(iFacl, 3).Value Then
    
30.    Dim iCol As Integer
    
31.    For iCol = 2 To 15
    
32.     Sheets("教师").Cells(iFacl, iCol + 4).Value = Sheets("NewSheet").Cells(iRow, iCol).Value
    
33.     Next iCol
    
34.    End If
    
35.    Next iRow
    
36.   
    
37. End Function
    
38. 
    
39. Public Function copyDataToALine(ByVal iNewSheetRow As Integer, ByVal wbSrc As Workbook, ByVal wbOrg As Workbook)
    
40. Dim iRow As Integer, iNewSheetCol As Integer
    
41. iNewSheetCol = 2
    
42. wbOrg.Sheets("NewSheet").Cells(iNewSheetRow, 1).Value = wbSrc.Sheets("Sheet1").Cells(3, 2).Value
    
43. 
    
44. For iRow = 5 To 19
    
45.   wbOrg.Sheets("NewSheet").Cells(iNewSheetRow, iNewSheetCol).Value = wbSrc.Sheets("Sheet1").Cells(iRow, 10).Value
    
46.   iNewSheetCol = iNewSheetCol + 1
    
47.   Next iRow
    
48. 
    
49. End Function
    
50. 
    
51. Public Function createNewSheet()
    
52. Dim i As Integer, NewSheet As Boolean
    
53. NewSheet = False
    
54. For i = 1 To Worksheets.Count
    
55.   If Sheets(i).Name = "NewSheet" Then
    
56.    NewSheet = True
    
57.    End If
    
58.    Next i
    
59.    
    
60. If NewSheet = False Then
    
61.   Worksheets.Add after:=Worksheets(Worksheets.Count)
    
62.   ActiveSheet.Name = "NewSheet"
    
63.   End If
    
64. End Function

复制代码

wangxml

代码复制至“教师”工作表

duquancai

实现不打开每一名员工个人的表？？？准确的说：不可能！用ADO+SQL方式也还是算打开了的。。。。。。。。。

duquancai

这种体力活，还是自己干吧！

lfg0327

非常感谢两个大师!