标签: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