[已解决]如何借助VBA批量将表格分几部分汇总

justawaylife · 发表于 2013-12-7 21:41

本帖最后由爱疯于 2013-12-8 08:40 编辑

数据上传了，主要是表格不规范，我又不能去让别人改表格，等于是批量修改表格布局，并汇总。求VBA代码。

样本.rar (33.04 KB, 下载次数: 26)

2013-12-7 21:39 上传

点击文件名下载附件

版主大大已经批评过我表格不规范了，我的目的就是规范表格，等于自动生成一个数据库。我没权力让别人改已经定版的表格，只能再把表格介绍详细点，请各位神通帮个忙。

最佳答案

sgxb123431380

2013-12-10 19:43

在汇总表中插入一个按钮写入下面的代码

Private Sub CommandButton1_Click()
ReDim OpData1(1 To 6, 1 To 999999)
ReDim OpData2(1 To 6, 1 To 999999)
OpData1N = 0
OpData2N = 0
MyPath = ThisWorkbook.Path & "\数据"
MyName = Dir(MyPath & "*.xlsx")
Do While MyName <> ""
Set wk = Workbooks.Open(MyPath & "" & MyName)
DataArr = wk.ActiveSheet.UsedRange.Value
TimeData = DataArr(2, 1)
i = 4
Do While DataArr(i + 1, 1) <> "尾巴"
i = i + 1
OpData1N = OpData1N + 1
For k = 1 To 5
OpData1(k, OpData1N) = DataArr(i, k)
Next k
OpData1(6, OpData1N) = TimeData
Loop
Do While i < UBound(DataArr)
i = i + 1
OpData2N = OpData2N + 1
For k = 1 To 5
OpData2(k, OpData2N) = DataArr(i, k)
Next k
OpData2(6, OpData2N) = TimeData
Loop
wk.Close False
MyName = Dir
Loop
ReDim Preserve OpData1(1 To 6, 1 To OpData1N)
ReDim Preserve OpData2(1 To 6, 1 To OpData2N)
ReDim OpData_1(1 To OpData1N, 1 To 6)
ReDim OpData_2(1 To OpData2N, 1 To 6)
For i = 1 To OpData1N
For j = 1 To 6
OpData_1(i, j) = OpData1(j, i)
Next j
Next i
For i = 1 To OpData2N
For j = 1 To 6
OpData_2(i, j) = OpData2(j, i)
Next j
Next i
ThisWorkbook.Sheets(1).Range("A" & ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1).Resize(OpData1N, 6).Value = OpData_1
ThisWorkbook.Sheets(2).Range("A" & ThisWorkbook.Sheets(2).Range("A65536").End(xlUp).Row + 1).Resize(OpData2N, 6).Value = OpData_2
End Sub

复制代码

代码执行前确保那些需要汇总的表里面的各种文本框什么的都删除掉，不要有多余的数据什么的就可以了
因为我是日文系统，所以你那个什么尾巴的打不出来，我就只保留“尾巴”两个字了

sgxb123431380 · 发表于 2013-12-10 19:43

在汇总表中插入一个按钮写入下面的代码

Private Sub CommandButton1_Click()
ReDim OpData1(1 To 6, 1 To 999999)
ReDim OpData2(1 To 6, 1 To 999999)
OpData1N = 0
OpData2N = 0
MyPath = ThisWorkbook.Path & "\数据"
MyName = Dir(MyPath & "*.xlsx")
Do While MyName <> ""
Set wk = Workbooks.Open(MyPath & "" & MyName)
DataArr = wk.ActiveSheet.UsedRange.Value
TimeData = DataArr(2, 1)
i = 4
Do While DataArr(i + 1, 1) <> "尾巴"
i = i + 1
OpData1N = OpData1N + 1
For k = 1 To 5
OpData1(k, OpData1N) = DataArr(i, k)
Next k
OpData1(6, OpData1N) = TimeData
Loop
Do While i < UBound(DataArr)
i = i + 1
OpData2N = OpData2N + 1
For k = 1 To 5
OpData2(k, OpData2N) = DataArr(i, k)
Next k
OpData2(6, OpData2N) = TimeData
Loop
wk.Close False
MyName = Dir
Loop
ReDim Preserve OpData1(1 To 6, 1 To OpData1N)
ReDim Preserve OpData2(1 To 6, 1 To OpData2N)
ReDim OpData_1(1 To OpData1N, 1 To 6)
ReDim OpData_2(1 To OpData2N, 1 To 6)
For i = 1 To OpData1N
For j = 1 To 6
OpData_1(i, j) = OpData1(j, i)
Next j
Next i
For i = 1 To OpData2N
For j = 1 To 6
OpData_2(i, j) = OpData2(j, i)
Next j
Next i
ThisWorkbook.Sheets(1).Range("A" & ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1).Resize(OpData1N, 6).Value = OpData_1
ThisWorkbook.Sheets(2).Range("A" & ThisWorkbook.Sheets(2).Range("A65536").End(xlUp).Row + 1).Resize(OpData2N, 6).Value = OpData_2
End Sub

复制代码

代码执行前确保那些需要汇总的表里面的各种文本框什么的都删除掉，不要有多余的数据什么的就可以了
因为我是日文系统，所以你那个什么尾巴的打不出来，我就只保留“尾巴”两个字了

justawaylife · 发表于 2013-12-10 20:52

sgxb123431380 发表于 2013-12-10 19:43
在汇总表中插入一个按钮写入下面的代码代码执行前确保那些需要汇总的表里面的各种文本框什么的都删除掉，不 ...

谢谢，一次通过，你太厉害了。原来需要这么多行，难怪挂了好几天没人理我，原来是在思考，谢谢。

sgxb123431380 · 发表于 2013-12-11 08:12

justawaylife 发表于 2013-12-10 20:52
谢谢，一次通过，你太厉害了。原来需要这么多行，难怪挂了好几天没人理我，原来是在思考，谢谢。

不客气，我也是昨天晚上才看现写的，主要不是不好写，是理解你里面的说明文字比较费事

justawaylife · 发表于 2013-12-18 20:31

sgxb123431380 发表于 2013-12-11 08:12
不客气，我也是昨天晚上才看现写的，主要不是不好写，是理解你里面的说明文字比较费事

主要是表格不规范，表述起来没有什么可以参考的东西，所以要重新建立一个概念的模型，我自己也不知道怎么表达顺畅，只好那样一点点地表达。

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