需求

给出一个空汇总表，和若干单独的 Excel 文件，每个文件里头有一个表格里存有一个人的信息，要将这些文件里的信息全部对应地导入到汇总表里。

以前写的，也不给实际例子了，直接上代码，逻辑不复杂，看看就明白。记在这里备以后查。

代码

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
Sub ExportMyFile()
    Dim myPath, myFileName
    Dim myCurOpenWB As Workbook 'work工作簿
    Dim myCurOpenWS As Worksheet 'work工作表
    Dim myTotalWS As Worksheet '汇总工作表
    
    Dim myFolderName As String
    myFolderName = "六堰"
    
    Set myTotalWS = ThisWorkbook.Sheets("附件4")    '汇总到表名为附件4的表格里
    
    myPath = ThisWorkbook.Path & "/" & myFolderName & "/*.xls"
    myFileName = Dir(myPath)   '''''''''''''''''''''''''''''''''''
    'Dim iCounter As Integer
    'iCounter = 0
    
    '遍历指定目录下的文件并操作
    Do '''''''''''''''''''''''''''''''''''''
        Debug.Print myFileName
        
        Dim searchStr As String '通用搜索字符串
        Dim resStr As String '通用结果字符串
        Dim iCount As Integer '通用计数器
        
        myFileName = ThisWorkbook.Path & "/" & myFolderName & "/" & myFileName
        
        '打开指定目录里的一个*.xls文件
        'Debug.Print myFileName
        Set myCurOpenWB = Workbooks.Open(myFileName)
        Set myCurOpenWS = myCurOpenWB.Sheets("附件1")   '打开文件的sheet附件1里是分条数据
        
        '插入内容行
        Dim iC As Integer
        For iC = 0 To 3
            '插入内容行
            myTotalWS.Rows(6).Insert
            myTotalWS.Rows(6).RowHeight = 14.25
            myTotalWS.Range("B6:Q6").NumberFormat = "@"   '将它们的数字格式设置成文本
        Next
        
        '##################################复制数据过程######################################
        '序号 =Row()-5
        myTotalWS.Range("A6").Formula = "=INT(Row()/4)"
        
        '姓名   C4
        myTotalWS.Range("B6").Value = myCurOpenWS.Range("C4").Value

        '性别   F4
        myTotalWS.Range("C6").Value = myCurOpenWS.Range("F4").Value
        
        '出生年月   C6
        myTotalWS.Range("D6").Value = myCurOpenWS.Range("C6").Value
        
        '身份证 D8
        myTotalWS.Range("E6").Value = myCurOpenWS.Range("D8").Value
        
        '进厂劳动时间   B21-B25
        myTotalWS.Range("F6").Value = myCurOpenWS.Range("B21").Value
        myTotalWS.Range("F7").Value = myCurOpenWS.Range("B22").Value
        myTotalWS.Range("F8").Value = myCurOpenWS.Range("B23").Value
        myTotalWS.Range("F9").Value = myCurOpenWS.Range("B24").Value
        
        '离岗时间   B21-B25
        
        '劳动年限   I26
        myTotalWS.Range("H6").Value = myCurOpenWS.Range("I26").Value
        
        '原用工单位 D21-D25
        'myTotalWS.Range("I6").Value = myFolderName
        myTotalWS.Range("I6").Value = myCurOpenWS.Range("D21").Value
        myTotalWS.Range("I7").Value = myCurOpenWS.Range("D22").Value
        myTotalWS.Range("I8").Value = myCurOpenWS.Range("D23").Value
        myTotalWS.Range("I9").Value = myCurOpenWS.Range("D24").Value
        
        '用工类别   D26
        myTotalWS.Range("J6").Value = "家属工"
        
        '已享受保障 B28-B30
        searchStr = myCurOpenWS.Range("B28").Value
        resStr = ""
        iCount = 0
        If InStr(searchStr, "√") <> 0 Then
            resStr = resStr & "城市最低生活保障"
            iCount = iCount + 1
        End If
        searchStr = myCurOpenWS.Range("B29").Value
        If InStr(searchStr, "√") <> 0 Then
            If iCount <> 0 Then
                resStr = resStr & "、"
            End If
            resStr = resStr & "遗属生活困难补助"
            iCount = iCount + 1
        End If
        searchStr = myCurOpenWS.Range("B30").Value
        If InStr(searchStr, "√") <> 0 Then
            If iCount <> 0 Then
                resStr = resStr & "、"
            End If
            resStr = resStr & "供养亲属抚恤费"
        End If
        myTotalWS.Range("K6").Value = resStr
        
        '已参加社保 B32-B34
        searchStr = myCurOpenWS.Range("B32").Value
        resStr = ""
        iCount = 0
        If InStr(searchStr, "√") <> 0 Then
            resStr = resStr & "企业职工养老保险"
            iCount = iCount + 1
        End If
        searchStr = myCurOpenWS.Range("B33").Value
        If InStr(searchStr, "√") <> 0 Then
            If iCount <> 0 Then
                resStr = resStr & "、"
            End If
            resStr = resStr & "灵活就业人员养老保险"
            iCount = iCount + 1
        End If
        searchStr = myCurOpenWS.Range("B34").Value
        If InStr(searchStr, "√") <> 0 Then
            If iCount <> 0 Then
                resStr = resStr & "、"
            End If
            resStr = resStr & "城镇居民医疗保险"
        End If
        myTotalWS.Range("L6").Value = resStr
        
        '配偶姓名   C10
        myTotalWS.Range("M6").Value = myCurOpenWS.Range("C10").Value
        
        '配偶现所在单位
        myTotalWS.Range("N6").Value = "重型车厂"
        
        '配偶人员类别   C12
        'myTotalWS.Range("O6").Value = myCurOpenWS.Range("C12").Value
        searchStr = myCurOpenWS.Range("C12").Value
        If InStr(searchStr, "√去世") <> 0 Then
            myTotalWS.Range("O6").Value = "去世"
        ElseIf InStr(searchStr, "√离休") <> 0 Then
            myTotalWS.Range("O6").Value = "离休"
        ElseIf InStr(searchStr, "√退休") <> 0 Then
            myTotalWS.Range("O6").Value = "退休"
        ElseIf InStr(searchStr, "√退养") <> 0 Then
            myTotalWS.Range("O6").Value = "退养"
        Else
            myTotalWS.Range("O6").Value = "在职"
        End If
        

        '备注
        myTotalWS.Range("P6").Value = myFolderName
        
        '联系电话
        myTotalWS.Range("Q6").Value = myCurOpenWS.Range("H18").Value

        '################################复制数据过程结束#############################
        
        '关闭打开的文件
        myCurOpenWB.Close
                
        myFileName = Dir   ''''''''''''''''''''''''''''''
    '    iCounter = iCounter + 1
    Loop Until myFileName = "" '''''''''''''''''''''''''''''
    
End Sub