一键角度统计

技术文章 1年前 (2020) 完美者
1,417 0

标签:resize   角度   ror   exce   save   active   string   false   hang   

 

把这几天写的程序,指定给一个控件,变成了一键式了。

不足之处是,执行效率太低了。

技术图片

 

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

 

一键角度统计

标签:resize   角度   ror   exce   save   active   string   false   hang   

原文地址:https://www.cnblogs.com/redufa/p/13621765.html

版权声明:完美者 发表于 2020-09-17 16:25:03。
转载请注明:一键角度统计 | 完美导航

暂无评论

暂无评论...