Public Sub GatherDataPicker()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>" 'On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim wb As Workbook
Dim Sht As Worksheet
Dim OpenWb As Workbook
Dim OpenSht As Worksheet
Const SHEET_INDEX = 1
Const OFFSET_ROW As Long = 1 Dim FolderPath As String
Dim FileName As String
Dim FileCount As Long '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Title = "请选取Excel工作簿所在文件夹"
If .Show = -1 Then
FolderPath = .SelectedItems(1)
Else
MsgBox "您没有选中任何文件夹，本次汇总中断！"
Exit Sub
End If
End With
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\" '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set wb = Application.ThisWorkbook '工作簿级别
'Set Sht = wb.ActiveSheet
'Sht.Cells.Clear 'FolderPath = ThisWorkbook.Path & "\"
FileCount = 0
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then
FileCount = FileCount + 1
Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
With OpenWb
'On Error Resume Next
Set OpenSht = OpenWb.Worksheets(1)
Debug.Print OpenSht.Name
'On Error GoTo 0
'If Not OpenSht Is Nothing Then
InsertFormula OpenSht
'Else ' End If .Close True
End With
End If
FileName = Dir
Loop
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
UsedTime = VBA.Timer - StartTime
MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio QQ嘻嘻哈哈" ErrorExit:
Set wb = Nothing
Set Sht = Nothing
Set OpenWb = Nothing
Set OpenSht = Nothing
Set Rng = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio QQ嘻嘻哈哈"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Sub ChartActiveSheet()
InsertFormula ActiveSheet
End Sub Sub InsertFormula(ByVal Sht As Worksheet)
With Sht
endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
For i = 1 To endrow
If .Cells(i, 1).Value Like "*T*" Then .Cells(i - 1, "C").FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
.Cells(i - 1, "C").AutoFill Destination:=.Cells(i - 1, "C").Resize(1, 18), Type:=xlFillDefault .Cells(i, "C").FormulaR1C1 = "=5*LOG10(R[-1]C/MIN(R[-4]C:R[-2]C))/LOG10(MAX(R[-4]C:R[-2]C)/MIN(R[-4]C:R[-2]C))"
.Cells(i, "C").AutoFill Destination:=.Cells(i, "C").Resize(1, 18), Type:=xlFillDefault
End If
Next i For Each shp In Sht.Shapes
shp.Delete
Next '前字
.Range("B101").Value = "时间点"
.Range("B102").Value = "平均T值"
For j = 2 + 1 To 2 + 9
s = 0
n = 0
For i = 1 To endrow
If .Cells(i, 1).Value Like "*T*" Then
'Debug.Print TypeName(.Cells(i, j).Value)
If .Cells(i, j).Value <> "" Then
n = n + 1
s = s + .Cells(i, j).Value
End If
End If
Next i
'Debug.Print s
avr = s / n .Cells(101, j).Value = j - 2
.Cells(102, j).Value = avr Next j
AddChartWith Sht, .Range("B102:K102"), "前字" '后字
.Range("K111").Value = "时间点"
.Range("K112").Value = "平均T值"
For j = 11 + 1 To 11 + 9
s = 0
n = 0
For i = 1 To endrow
If .Cells(i, 1).Value Like "*T*" Then
If .Cells(i, j).Value <> "" Then
n = n + 1
s = s + .Cells(i, j).Value
End If
End If
Next i
avr = s / n
.Cells(111, j).Value = j - 11
.Cells(112, j).Value = avr
Next j AddChartWith Sht, .Range("K112:T112"), "后字" End With Set wb = Nothing
Set Sht = Nothing
End Sub Sub AddChartWith(ByVal Sht As Worksheet, ByVal Rng As Range, ByVal Title As String)
Dim cht As Chart
Sht.Shapes.AddChart2(227, xlLineMarkers).Select
Set cht = Sht.Shapes(Sht.Shapes.Count).Chart
cht.SetSourceData Source:=Rng
cht.ChartTitle.Text = Title
Set cht = Nothing
End Sub