如何通过VBA整理复杂的数据源，实际工作遇到的难题

mml1988 · 发表于 2015-8-1 22:05

实际工作碰到的难题，关于研发部门费用的统计分析，具体的要求和案例数据在附件有详细介绍，求高手帮忙！谢谢

看见星光 · 发表于 2015-8-1 22:35

本帖最后由看见星光于 2015-8-1 22:37 编辑

Sub mml()
Dim arr, brr, i&, j&, k&, n&, myr&
myr = ActiveSheet.Index
ReDim brr(1 To Cells.Rows.Count, 1 To 7)
For i = 1 To myr - 1
arr = Sheets(i).[b3].CurrentRegion
For j = 3 To UBound(arr)
For n = 4 To UBound(arr, 2)
If arr(1, n) = "" Then arr(1, n) = arr(1, n - 1)
If arr(2, n) <> "小计" Then
k = k + 1
brr(k, 1) = k
brr(k, 2) = arr(j, 2)
brr(k, 3) = arr(j, 3)
brr(k, 4) = Sheets(i).Name
brr(k, 5) = arr(1, n)
brr(k, 6) = arr(2, n)
brr(k, 7) = arr(j, n)
End If
Next
Next
Next
Range("b5:h" & Cells.Rows.Count).ClearContents
[b5].Resize(k, 7) = brr
End Sub

复制代码

看见星光 · 发表于 2015-8-1 22:36

本帖最后由看见星光于 2015-8-1 22:37 编辑

附件参考

300.zip (267.6 KB, 下载次数: 28)

mml1988 · 发表于 2015-8-2 08:38

@看见星光，大神太厉害了！本来要手工贴25000行数据，现在几秒搞定！测试了一下，有个很小的问题，运行代码后，“数据处理”表中项目序号并不是基础表“机械，硬件…”的项目序号，这个怎么修改代码？再次感谢！

huang1314wei · 发表于 2015-8-2 09:33

mml1988 发表于 2015-8-2 08:38
@看见星光，大神太厉害了！本来要手工贴25000行数据，现在几秒搞定！测试了一下，有个很小的问题，运行代码 ...

把大神代码改一个地方

Sub mml()
Dim arr, brr, i&, j&, k&, n&, myr&
myr = ActiveSheet.Index
ReDim brr(1 To Cells.Rows.Count, 1 To 7)
For i = 1 To myr - 1
arr = Sheets(i).[b3].CurrentRegion
For j = 3 To UBound(arr)
For n = 4 To UBound(arr, 2)
If arr(1, n) = "" Then arr(1, n) = arr(1, n - 1)
If arr(2, n) <> "小计" Then
k = k + 1
brr(k, 1) = arr(j, 1)
brr(k, 2) = arr(j, 2)
brr(k, 3) = arr(j, 3)
brr(k, 4) = Sheets(i).Name
brr(k, 5) = arr(1, n)
brr(k, 6) = arr(2, n)
brr(k, 7) = arr(j, n)
End If
Next
Next
Next
Range("b5:h" & Cells.Rows.Count).ClearContents
[b5].Resize(k, 7) = brr
End Sub

复制代码

zax010 · 发表于 2015-8-2 10:09

Sub zz()
Set sh = Sheet8
Application.ScreenUpdating = False
For x = 1 To 7
      With Sheets(x)
         a = .[b5:d14]: s = 5
         For i = 5 To .[xfd4].End(xlToLeft).Column
            If .Cells(4, i) <> "小计" Then
                  sh.Cells(5 + n, 2).Resize(10, 3) = a
                  sh.Cells(5 + n, 5).Resize(10, 3) = Array(Sheets(x).Name, .Cells(3, s), .Cells(4, i))
                  sh.Cells(5 + n, 8).Resize(10, 1) = .Cells(5, i).Resize(10, 1).Value
                  n = n + 10
            Else
                  s = i + 1
            End If
         Next
      End With
Next
Application.ScreenUpdating = True
End Sub

zax010 · 发表于 2015-8-2 10:12

>>>>>>>>>>>>>>>>>>>>>>>>>>

案例数据.rar (140.47 KB, 下载次数: 12)

mml1988 · 发表于 2015-8-2 16:54

huang1314wei 发表于 2015-8-2 09:33
把大神代码改一个地方

嗯，可以了。十分感谢！

mml1988 · 发表于 2015-8-2 17:02

看见星光发表于 2015-8-1 22:35

谢谢大神！还有一个问题，实际工作中需要将每个费用添加subtotal，如附件表格“机械部、、、项目部”第二行，但是这样VBA就不能达到之前的效果了，请大神再次帮忙啊，十分感谢！

看见星光 · 发表于 2015-8-2 21:48

mml1988 发表于 2015-8-2 17:02
谢谢大神！还有一个问题，实际工作中需要将每个费用添加subtotal，如附件表格“机械部、、、项目部”第二 ...

Sub mml()
Dim arr, brr, i&, j&, k&, n&, myr&
myr = ActiveSheet.Index
ReDim brr(1 To Cells.Rows.Count, 1 To 7)
For i = 1 To myr - 1
arr = Sheets(i).[b3].CurrentRegion
For j = 4 To UBound(arr)
For n = 4 To UBound(arr, 2)
If arr(2, n) = "" Then arr(2, n) = arr(2, n - 1)
If arr(2, n) <> "小计" Then
k = k + 1
brr(k, 1) = arr(j, 1)
brr(k, 2) = arr(j, 2)
brr(k, 3) = arr(j, 3)
brr(k, 4) = Sheets(i).Name
brr(k, 5) = arr(2, n)
brr(k, 6) = arr(3, n)
brr(k, 7) = arr(j, n)
End If
Next
Next
Next
Range("b5:h" & Cells.Rows.Count).ClearContents
[b5].Resize(k, 7) = brr
End Sub

复制代码

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

[求助] 如何通过VBA整理复杂的数据源，实际工作遇到的难题