vba实现自动累加文件夹中所有表单,并完成绘图功能-bat文件

需求如下,文件下有某网站的来自某运营商十大节点流量汇总,每个文件内为每天忙时19-21点流量统计,实现所有数据累加汇总,并且完成绘图功能。若有实现自动化操作excel朋友可以在线联系小编。

vba实现自动累加文件夹中所有表单,并完成绘图功能

小编【shellbat】总计花了一天时间完成此项工作,能兴趣的小伙伴可以可以自己尝试,需要原始数据可以联系小编索取。

vba实现自动累加文件夹中所有表单,并完成绘图功能

具体vba代码如下:

Sub 宏1()

On Error Resume Next

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim Num As Long

Dim BOX As String

Dim rows As Long

Application.ScreenUpdating = False

Columns("A:I").ClearContents

Application.CutCopyMode = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath & "\" & "*.xls")

AWbName = ActiveWorkbook.Name

'Application.WindowState = xlMinimized

Num = 0

'累加数值

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = Workbooks.Open(MyPath & "\" & MyName)

Num = Num + 1

If Num = 1 Then

Workbooks(MyName).Activate

rws = Worksheets(1).Range("A65535").End(xlUp).Row

Range("A1:I" & rws).Copy

ThisWorkbook.Activate

Range("A1").Select

ActiveSheet.Paste

Range("Q24").Copy

Range("C4:I" & rws).Select

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

'Application.WindowState = xlMinimized

Else

Workbooks(MyName).Activate

Range("C7:I" & rws).Copy

ThisWorkbook.Activate

Range("C7").PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _

False, Transpose:=False

Application.CutCopyMode = False

'Application.WindowState = xlMinimized

End If

If Num Mod 5 = 1 And Num <> 1 Then

WbN = WbN & Chr(13) & Wb.Name

ElseIf Num = 1 Then

WbN = Wb.Name

Else

WbN = WbN & " " & Wb.Name

End If

Application.DisplayAlerts = False

Wb.Close False

End If

MyName = Dir

Loop

'求最大,平均,最小

ThisWorkbook.Activate

Range("C4:I6").ClearContents

Range("C4").FormulaR1C1 = "=MAX(R[3]C:R[" & rws - 4 & "]C)"

Range("C5").FormulaR1C1 = "=AVERAGE(R[2]C:R[" & rws - 5 & "]C)"

Range("C6").FormulaR1C1 = "=MIN(R[1]C:R[" & rws - 6 & "]C)"

Range("C4:C6").Select

Selection.AutoFill Destination:=Range("C4:I6"), Type:=xlFillDefault

Range("C4:I6").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

'制作图表

'Application.WindowState = xlMaximized

ThisWorkbook.Activate

ActiveSheet.ChartObjects("chart1").Activate

ActiveChart.Parent.Delete

Range("B3,D3:I3,B7:B" & rws & ",D7:" & rws).Select

Range("B7").Activate

ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select

ActiveChart.SetSourceData Source:=Range("Sheet1!$B$3,Sheet1!$D$3:$I$3,Sheet1!$D$7:$I$" & rws & ",Sheet1!$B$7:$B$" & rws)

ActiveChart.Parent.Name = "chart1"

ActiveSheet.Shapes("chart1").IncrementLeft 205

ActiveSheet.Shapes("chart1").IncrementTop 18.5

ActiveSheet.Shapes("chart1").ScaleWidth 1.225, msoFalse, msoScaleFromTopLeft

ActiveSheet.Shapes("chart1").ScaleHeight 1#, msoFalse, msoScaleFromTopLeft

ActiveChart.ChartTitle.Delete

ActiveSheet.ChartObjects("chart1").Activate

ActiveChart.PlotArea.Select

ActiveChart.ChartType = xlLine

Application.CommandBars("Format Object").Visible = False

ThisWorkbook.Activate

Application.ScreenUpdating = True

'Windows("all.xlsm").Activate

ThisWorkbook.Activate

ActiveWindow.FreezePanes = False

ActiveWindow.SmallScroll Down:=0

Sheets(1).Range("A1").Select

ThisWorkbook.Save

MsgBox "累加计算数据" & Num & "个工作表。如下:" & Chr(13) & WbN, vbInformation, "完成提示,by shellbat!"

End Sub

推荐阅读