一键角度统计

Sub 一键计算()

Dim Wb As Workbook, MyPath, File   As String


MyPath = ThisWorkbook.Path & "\"

File = Dir(MyPath & "*.xlsx*") 'excle的文件的扩展名有两种

k = 1

Do While File <> "" '遍历所有文件


If File <> ThisWorkbook.Name Then '不是 当前工作簿
Set Wb = Workbooks.Open(MyPath & File)

Wb.Sheets(1).Select

Call ts

With ThisWorkbook.Sheets(1)
    .Cells(1, 2) = "数据文件名"
    .Cells(1, 3) = "M型": .Cells(1, 4) = "水平":
    .Cells(1, 5) = "拱型": .Cells(1, 6) = "其他"
    .Cells(k + 1, 2) = Wb.Name
    .Cells(k + 1, 3) = Wb.Sheets(1).Cells(1, 57)
        .Cells(k + 1, 4) = Wb.Sheets(1).Cells(1, 58)
            .Cells(k + 1, 5) = Wb.Sheets(1).Cells(1, 59)
                .Cells(k + 1, 6) = Wb.Sheets(1).Cells(1, 60)
     
     End With
     
 

Wb.Close False '关闭工作簿 不保存
k = k + 1

End If
File = Dir
Rem 循环下一个工作簿
Loop

ThisWorkbook.Save


End Sub



Sub ts()
On Error Resume Next

n = Cells(Rows.Count, 2).End(xlUp).Row

Call ts1(n): dq (n): Call qd: jd

Application.DisplayAlerts = False
     ActiveWorkbook.Save
    'ActiveWorkbook.Close savechanges = True     '关闭打开的文件
        ' Application.Quit   退出excel

End Sub

Sub ts1(n)

On Error Resume Next
For i = 2 To n
If Range("L" & i) <> "" Then

j = Range("M" & i - 1).End(xlDown).Row
If j - i < 3 Then
Range("M" & j).Resize(1, 3).Cut Range("M" & i).Resize(1, 3)
End If: End If:  Debug.Print "1---" & i
 
Next i

End Sub


Sub dq(n)
On Error Resume Next
j = 2
For i = 2 To n
If Cells(i, 2) <> "" Then

Cells(i, 1).Resize(1, 5).Copy Cells(j, 17).Resize(1, 5)

j = j + 1
End If
Next
j = 2
For i = 2 To n
If Cells(i, 6) <> "" Then
Cells(i, 6).Resize(1, 3).Copy Cells(j, 22).Resize(1, 3)

j = j + 1
End If
Next

j = 2
For i = 2 To n
If Cells(i, 9) <> "" Then
Cells(i, 9).Resize(1, 3).Copy Cells(j, 25).Resize(1, 3)
j = j + 1
End If
Next
j = 2
For i = 2 To n
If Cells(i, 12) <> "" Then

Cells(i, 12).Resize(1, 4).Copy Cells(j, 28).Resize(1, 4)

j = j + 1
End If
Next

End Sub

Sub qd()
On Error Resume Next
''去除o，非打泵
n = Cells(Rows.Count, 30).End(xlUp).Row
j = 0

For i = n To 2 Step -1
If Cells(i, 30) = 0 Then
       Cells(i, 17).Resize(1, 15).Delete Shift:=xlUp
         j = j + 1
         End If
Next

Debug.Print "去除o值个数：" & j
    
End Sub

Sub jd()
On Error Resume Next

n = Cells(Rows.Count, 17).End(xlUp).Row
gk1 = 1: gk2 = 1: gk3 = 1: gk4 = 1
For i = 2 To n
If Cells(i, 20) < -30 And Cells(i, 21) > 30 Then
gk1 = gk1 + 1
Cells(i, 18).Resize(1, 6).Copy Cells(gk1, 33).Resize(1, 6)

ElseIf Cells(i, 18) < 30 And Cells(i, 19) < 30 Then
gk2 = gk2 + 1
Cells(i, 18).Resize(1, 6).Copy Cells(gk2, 39).Resize(1, 6)

ElseIf Cells(i, 18) > 30 Then
gk3 = gk3 + 1
Cells(i, 18).Resize(1, 6).Copy Cells(gk3, 45).Resize(1, 6)

Else: gk4 = gk4 + 1
Cells(i, 18).Resize(1, 6).Copy Cells(gk4, 51).Resize(1, 6)

End If

Debug.Print "n=" & n & "/i=" & i

Next
Cells(1, 33) = "M工况": Cells(1, 39) = "水平工况":
Cells(1, 45) = "拱型工况": Cells(1, 51) = "其他工况"
Debug.Print "M型：" & gk1 - 1: Debug.Print "水平：" & gk2 - 1
Debug.Print "拱型：" & gk3 - 1: Debug.Print "其他：" & gk4 - 1

Cells(1, 34) = Cells(Rows.Count, 35).End(xlUp).Row - 1
Cells(1, 40) = Cells(Rows.Count, 41).End(xlUp).Row - 1
Cells(1, 46) = Cells(Rows.Count, 47).End(xlUp).Row - 1
Cells(1, 52) = Cells(Rows.Count, 53).End(xlUp).Row - 1

Cells(1, 56) = "四种工况汇总"
Cells(1, 57) = Cells(1, 34): Cells(1, 58) = Cells(1, 40)
Cells(1, 59) = Cells(1, 46): Cells(1, 60) = Cells(1, 52)



End Sub