多工作簿报表汇总

4684890

谢谢，这几天在出差，可能回复的比较慢，感谢

清风竹-

4684890 发表于 2013-4-27 20:29
...意思有些问题，不是要求季度合并，假如5月时，应该是1-5月之和

Sub 利润汇()
Dim wj As String, fs As Object, gs As Byte
Application.ScreenUpdating = False
Application.DisplayAlerts = False



yue = Split([a3], "月")(0) '新加

wj = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While wj <> ""
If wj <> ThisWorkbook.Name Then
Set fs = GetObject(ThisWorkbook.Path & "\" & wj)
gs = Application.CountA(Range("A6:IV6"))
For i = 3 To gs
If Cells(6, i).Value = Split(wj, ".xlsx")(0) Then
i2 = i
Exit For
End If
Next


Cells(9, i2).Resize(31, 1).ClearContents '新加，清除内容。


For j = 1 To yue '新加


  fs.Sheets("利润分析表（月度）").Range("C9:C40").Offset(0, j - 1).Copy
  Cells(9, i2).PasteSpecial xlPasteValues, Operation:=xlAdd '改

  
  fs.Sheets("利润分析表（月度）").Range("U9:U40").Offset(0, (Split([a3], "月")(0)) - 1).Copy
  Cells(9, i2 + gs / 3 + 2).PasteSpecial xlPasteValues ' '待改
  
  fs.Sheets("利润分析表（月度）").Range("AM9:AM40").Offset(0, (Split([a3], "月")(0)) - 1).Copy
  Cells(9, i2 + gs / 3 + 2 + gs / 3 + 2).PasteSpecial xlPasteValues  '待改
  
   Next '新加
  
fs.Close
End If
wj = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
以上是修改过的代码，同时把窗体（32楼附件中的）删除。两个待改的语句，可参照已改的语句修改，同时增加清除区域内容的语句。

4684890

清风竹- 发表于 2013-4-26 19:08
家中的是2003版，不能测试，上班时不能上网。测试一下这个文件，有些语句需要自己修改。

...意思有些问题，不是要求季度合并，假如5月时，应该是1-5月之和

4684890

清风竹- 发表于 2013-3-29 06:30
fs.Sheets("资产负债表").Range("D8:D82").Offset(0, (Split(, "月")(0)) - 1).Copy
                  ...

不好意思又来麻烦您了
按月汇总没有问题了，但是实际会要例如1-3月的汇总数，这个应该怎么修改下。。。表和公司都很多，就留了一个表

清风竹-

4684890 发表于 2013-4-25 11:16
不好意思又来麻烦您了
按月汇总没有问题了，但是实际会要例如1-3月的汇总数，这个应该怎么修改下。。。表 ...

家中的是2003版，不能测试，上班时不能上网。测试一下这个文件，有些语句需要自己修改。