不规则表的数据提取问题

zzzxxxmmm · 发表于 2020-2-12 10:14

本帖最后由心电感应于 2020-2-12 10:44 编辑

职工的健康卡是不规则，总数有几百个表，要转换为一维表进行汇总统计。复制粘贴是万能的，但肯定万万不能。
本人是个vba小白，求大神出手。需要的结果是“健康卡汇总表”样式，并且想要以后如果表结构改变了，可以简单修改一下提取数据的单元格位置（这个我会干）就能搞定，，万能的vba代码。这个像是有些贪得无厌吧。谢谢。

chxw68 · 发表于 2020-2-12 11:29

Sub test()
Dim r%, i%
Dim arr, brr(1 To 1000, 1 To 49)
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vs = [{2,2;2,4;2,6;2,8;3,2;3,5;4,3;5,3;5,7;6,3}]
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xlsx")
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
Set wb = GetObject(mypath & myname)
With wb
With .Worksheets("sheet1")
arr = .Range("a1:h18")
m = m + 1
For k = 1 To UBound(vs)
brr(m, k) = arr(vs(k, 1), vs(k, 2))
Next
n = 11
For i = 10 To UBound(arr)
If Len(arr(i, 1)) <> 0 Then
brr(m, n) = arr(i, 1)
brr(m, n + 1) = arr(i, 2)
brr(m, n + 2) = arr(i, 3)
brr(m, n + 3) = arr(i, 4)
brr(m, n + 4) = arr(i, 6)
brr(m, n + 5) = arr(i, 7)
brr(m, n + 6) = arr(i, 8)
n = n + 7
End If
Next
End With
.Close False
End With
End If
myname = Dir
Loop
With Worksheets("sheet1")
.UsedRange.Offset(1, 0).Clear
.Columns(8).NumberFormatLocal = "@"
.Range("a2").Resize(m, UBound(brr, 2)) = brr
End With
Application.ScreenUpdating = True
MsgBox "数据提取完毕！"
End Sub

复制代码

chxw68 · 发表于 2020-2-12 11:29

详见附件。

liulang0808 · 发表于 2020-2-12 12:21

完成了部分汇总，其他楼主可以参考补充
另外汇总表里的后面部分有空列，已经删除。
供参考

阿诺斯瓦星呆 · 发表于 2020-2-12 12:25

幸好我收藏了一个帖子，里面有模板，http://club.excelhome.net/thread-1409141-1-1.html

zzzxxxmmm · 发表于 2020-2-12 15:00

谢谢。。。。。。。。。。。

zzzxxxmmm · 发表于 2020-2-12 15:02

liulang0808 发表于 2020-2-12 12:21
完成了部分汇总，其他楼主可以参考补充
另外汇总表里的后面部分有空列，已经删除。
供参考

我只会这个，，补充了一下，好像可以用了，谢谢。。。
Sub 按钮1_Click()
Set fso = CreateObject("Scripting.FileSystemObject")
brr = Array(1, 2, 3, 4, 6, 7, 8)
Application.ScreenUpdating = False
Set sh = ActiveSheet
sh.UsedRange.Offset(1).ClearContents
r = 2
      For Each f In fso.getfolder(ThisWorkbook.Path).Files
      If InStr(f.Name, "健康卡汇总表") = 0 Then
         With Workbooks.Open(f)

            sh.Cells(r, 1) = .Sheets(1).[b2]
            sh.Cells(r, 2) = .Sheets(1).[d2]
            sh.Cells(r, 3) = .Sheets(1).[f2]
            sh.Cells(r, 4) = .Sheets(1).[h2]
            sh.Cells(r, 5) = .Sheets(1).[b3]
            sh.Cells(r, 6) = .Sheets(1).[e3]
            sh.Cells(r, 7) = .Sheets(1).[c4]
            sh.Cells(r, 8) = .Sheets(1).[c5]
            sh.Cells(r, 9) = .Sheets(1).[c6]
            sh.Cells(r, 10) = .Sheets(1).[b10]

            c = 11
            For j = 10 To .Sheets(1).Cells(Rows.Count, 1).End(3).Row
                  For Each i In brr
                     sh.Cells(r, c) = .Sheets(1).Cells(j, i)
                     c = c + 1
                  Next
            Next j
            .Close False
         End With
         r = r + 1
      End If
Next f
Application.ScreenUpdating = True
End Sub

zzzxxxmmm · 发表于 2020-2-12 15:45

liulang0808 发表于 2020-2-12 12:21
完成了部分汇总，其他楼主可以参考补充
另外汇总表里的后面部分有空列，已经删除。
供参考

我完善了下，能用了。谢谢。。
Sub 按钮1_Click()    '表头先单独单独设置好
Set fso = CreateObject("Scripting.FileSystemObject")
brr = Array(1, 2, 3, 4, 6, 7, 8)
Application.ScreenUpdating = False
Set sh = ActiveSheet
sh.UsedRange.Offset(1).ClearContents
r = 2
      For Each f In fso.getfolder(ThisWorkbook.Path).Files
      If InStr(f.Name, "健康卡汇总表") = 0 Then
         With Workbooks.Open(f)                '修改，不同表修改数据提取单元格位置
            sh.Cells(r, 1) = .Sheets(1).[b2] '等号前为汇总表字段列号，等号后是不规则表单元格代码，姓名
            sh.Cells(r, 2) = .Sheets(1).[d2] '性别
            sh.Cells(r, 3) = .Sheets(1).[f2] '年龄
            sh.Cells(r, 4) = .Sheets(1).[h2] '民族
            sh.Cells(r, 5) = .Sheets(1).[b3] '出生日期
            sh.Cells(r, 6) = .Sheets(1).[e3] '家庭住址
            sh.Cells(r, 7) = .Sheets(1).[c4] '工作单位
            sh.Cells(r, 8) = .Sheets(1).[c5] '身份证
            sh.Cells(r, 9) = .Sheets(1).[g5] '联系电话
            sh.Cells(r, 10) = .Sheets(1).[c6]    '离昌情况
            sh.Cells(r, 11) = .Sheets(1).[c7] '健康状况

            c = 11
            For j = 10 To .Sheets(1).Cells(Rows.Count, 1).End(3).Row
                  For Each i In brr
                     sh.Cells(r, c) = .Sheets(1).Cells(j, i)
                     c = c + 1
                  Next
            Next j
            .Close False
         End With
         r = r + 1
      End If
Next f
Application.ScreenUpdating = True
End Sub

zzzxxxmmm · 发表于 2020-2-12 15:46

chxw68 发表于 2020-2-12 11:29
详见附件。

谢谢大神。。。。。。。。。。。。

excel海 · 发表于 2020-2-12 18:13

真是不规则,连结果表都不规则,搞几个无用空列

,空列已删除

Sub 不规则汇总()
Dim i, arr, n, mypath, k, brr(), m, crr, j, l
Dim wbk As Workbook
Dim rng As Range
Dim fd, f, fs
Application.ScreenUpdating = False
Set fs = CreateObject("scripting.filesystemobject")
With Sheet1
n = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:AW1")
End With
mypath = ThisWorkbook.Path & ""
Set fd = fs.getfolder(mypath)
For Each f In fd.Files
If f.Name <> ThisWorkbook.Name And Not f.Name Like "~$*" Then
With Workbooks.Open(mypath & f.Name)
k = k + 1
ReDim Preserve brr(1 To UBound(arr, 2), 1 To k)
For i = 1 To Range("J1").Column
Set rng = .Sheets(1).Range("A2:H7").Find(arr(1, i), lookat:=xlWhole)
brr(i, k) = rng.Offset(0, 1)
Next
m = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
crr = .Sheets(1).Range("A9:h" & m)
l = Range("J1").Column
For i = 2 To UBound(crr)
For j = 1 To UBound(crr, 2)
If j <> 5 Then
l = l + 1
brr(l, k) = crr(i, j)
End If
Next
Next
.Close False
End With
End If
Next
ReDim drr(1 To UBound(brr, 2), 1 To UBound(brr))
For i = 1 To UBound(drr)
For j = 1 To UBound(drr, 2)
drr(i, j) = brr(j, i)
Next
Next
Sheet1.Cells(2, 1).Resize(UBound(drr), UBound(drr, 2)).ClearContents
Sheet1.Cells(2, 1).Resize(UBound(drr), UBound(drr, 2)) = drr
Application.ScreenUpdating = True
End Sub

复制代码

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

[求助] 不规则表的数据提取问题

评分

评分

评分