|
- Sub 合并()
- Dim Wb As Workbook, Sh As Worksheet
- Dim brr(1 To 100000, 1 To 26)
- On Error Resume Next
- Workbooks.Open (ThisWorkbook.Path & "\一人一表.xls")
- Set Wb = Workbooks("一人一表.xls")
- On Error GoTo 0
- For Each Sh In Wb.Worksheets
- If Application.WorksheetFunction.CountA(Sh.[a:a]) > 0 Then '非空表
- arr = Sh.[a1].CurrentRegion
- For i = 1 To UBound(arr)
- If arr(i, 1) = "姓名" And arr(i, 2) <> "" Then
- n = n + 1
- na = 0: nb = 0: nc = 0
- brr(n, 1) = arr(i, 2) '姓名
- brr(n, 2) = arr(i, 8) '性别
- brr(n, 3) = arr(i, 14) '出生年月
- brr(n, 4) = arr(i, 21) '籍贯
-
- brr(n, 5) = arr(i + 1, 2) '文化程度
- brr(n, 6) = arr(i + 1, 8) '民族
- brr(n, 7) = arr(i + 1, 14) '工作年月
- brr(n, 8) = arr(i + 1, 21) '职务
-
- brr(n, 9) = arr(i + 2, 2) '退休日期
- brr(n, 10) = arr(i + 2, 8) '专业职务
- brr(n, 11) = arr(i + 2, 14) '评审时间
- brr(n, 12) = arr(i + 2, 18) '党派
- brr(n, 13) = arr(i + 2, 23) '何时参加
-
- brr(n, 14) = arr(i + 3, 2) '家庭住址
- brr(n, 15) = arr(i + 3, 18) '联系电话
-
- sfz = "" '身份证
- For j = 3 To UBound(arr, 2)
- sfz = sfz & arr(i + 4, j)
- Next
- brr(n, 16) = sfz
-
- For j = i + 6 To i + 15 '主要经历
- If arr(j, 9) <> "" Then
- na = na + 1
- brr(n + na - 1, 18) = arr(j, 2)
- brr(n + na - 1, 19) = arr(j, 6)
- brr(n + na - 1, 20) = arr(j, 9)
- End If
- Next
-
- For j = i + 17 To i + 20 '其它情况
- If arr(j, 6) <> "" Then
- nb = nb + 1
- brr(n + nb - 1, 22) = arr(j, 2)
- brr(n + nb - 1, 23) = arr(j, 6)
- End If
- Next
-
- For j = i + 22 To i + 25 '奖励贡献
- If arr(j, 6) <> "" Then
- nc = nc + 1
- brr(n + nc - 1, 25) = arr(j, 2)
- brr(n + nc - 1, 26) = arr(j, 6)
- End If
- Next
-
- k = Application.Max(na, nb, nc)
- If k > 0 Then n = n + k - 1
- i = j '当前指针下移到当前表最下行
- End If
- Next
- End If
- Next
-
- If n > 0 Then [a6].Resize(n, 26) = brr
- Wb.Close False
-
- End Sub
复制代码 |
|