|
楼主 |
发表于 2020-2-23 22:52
|
显示全部楼层
本帖最后由 crega123 于 2020-2-23 23:28 编辑
我想到了,能帮我优化一下代码吗?
Sub 汇总2()
Dim q As Integer
q = MsgBox("是否要汇总", 1, "汇总")
If q = 2 Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
Set rng = Nothing
For j = 2 To Cells(Rows.Count, 11).End(3).Row
If InStr(Cells(j, 3), "东莞") > 0 Then
If rng Is Nothing Then
Set rng = Cells(j, 1).Resize(1, 11)
Else
Set rng = Union(rng, Cells(j, 1).Resize(1, 11))
End If
End If
Next j
If Not rng Is Nothing Then rng.Copy Cells(ActiveSheet.UsedRange.Rows.Count + 7, 1)
rng.EntireRow.Delete
End With
On Error Resume Next
Dim arr, brr
arr = Range("A1").CurrentRegion
With Range("a2").Resize(UBound(arr), UBound(arr, 2))
.Value = arr
.Sort Key1:=Range("B2").Resize(UBound(arr)), Order1:=xlAscending, Key2:=Range("D2").Resize(UBound(arr)), Order2:=xlAscending, Key3:=Range("E2").Resize(UBound(arr)), Order3:=xlAscending
.RemoveSubtotal
.Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
End With
r = Cells(Range("A1").CurrentRegion.Rows.Count, 1).End(xlUp).Row
Range("a1:k1").Copy Cells(r + 6, 1)
brr = Cells(Range("A1").CurrentRegion.Rows.Count + 5, 1).CurrentRegion.Select
With Selection
.Sort Key1:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 2), Order1:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 4), Order2:=xlAscending, Key2:=Cells(Range("A1").CurrentRegion.Rows.Count + 5, 5), Order3:=xlAscending
.RemoveSubtotal
.Subtotal GroupBy:=2, Function:=xlCount, TotalList:=Array(2)
.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(8)
Set DRNG = Intersect(arr, Selection)
With DRNG
.Borders.LineStyle = xlContinuous '所有框线
.HorizontalAlignment = xlCenter '水平对齐=居中
.VerticalAlignment = xlCenter '垂直对齐=居中
Set myFon = .Range("B:B,H:H").Font
With myFon
.Name = "宋体(正文)"
.Size = 11
.Bold = True
With Range("C:F").Font
.Name = "宋体(正文)"
.Size = 9
End With
End With
End With
Dim oWK As Worksheet
Set oWK = ActiveSheet
With oWK
Set oRng = .Range("A:A,G:G,I:K").EntireColumn
oRng.Hidden = True
End With
End With
Application.ScreenUpdating = True
End Sub
|
|