我有一个简单的代码,将1张表的所有内容复制并粘贴到另一张表中,大多数情况下,代码完成运行后,excel文件会关闭并再次打开(但没有任何信息)。
这段代码是由用户表单中的CommandButton1调用的。我把代码放在用户表单中,因为我使用列表框来选择正确的表来复制信息。
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag
Application.Calculation = xlCalculationManual
Dim sheet_name As String
Dim oShape As Shape
Alert.Rows("15:" & Rows.count).ClearContents
Alert.Activate
For Each oShape In ActiveSheet.Shapes
If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Rows("15:" & Rows.count)) Is Nothing Then
oShape.Delete
End If
Next
Dim i As Integer, sht As String
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
sht = ListBox1.List(i)
End If
Next i
Sheets(sht).Activate
Application.EnableEvents = False
ActiveSheet.Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = ActiveSheet.Range("C1:C2").Value
Alert.Range("H2:L3").Value = ActiveSheet.Range("H2:L3").Value
Alert.Range("H5:L10").Value = ActiveSheet.Range("H5:L10").Value
Alert.Range("B34") = ActiveSheet.Name
ActiveSheet.Delete
Call rename
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True: Application.EnableEvents = True
End Sub
重命名子也是一个简单的代码。
Sub rename()
Dim ws As Worksheet
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag
Alert.Activate
Alert.Name = Alert.Range("B34")
Alert.Range("B34") = ""
Range("L2:L3").Select
Range("L5:L10").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Alert.Range("A1").Activate
Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True: Application.EnableEvents = True
End Sub
我如何防止它崩溃?
我建议使用 DoEvents
并避免 select
& activate
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False: Application.DisplayAlerts = False:
Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag
Application.Calculation = xlCalculationManual
Dim sheet_name As String
Dim oShape As Shape
Alert.Rows("15:" & Rows.count).ClearContents
Alert.Activate
DoEvents
For Each oShape In Alert.Shapes
If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
oShape.Delete
End If
Next
Dim i As Integer, sht As String
DoEvents
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
sht = ListBox1.List(i)
End If
Next i
Application.EnableEvents = False
Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value
Alert.Range("B34") = Sheets(sht).Name
Sheets(sht).Delete
Call rename
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True: Application.DisplayAlerts = True:
Application.AskToUpdateLinks = True: Application.EnableEvents = True
End Sub
Sub rename()
Dim ws As Worksheet
Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag
Alert.Name = Alert.Range("B34")
Alert.Range("B34") = ""
DoEvents
With Alert.Range("L5:L10")
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
DoEvents
With Alert.Range("L2:L3")
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True:
Application.AskToUpdateLinks = True: Application.EnableEvents = True
End Sub
这是一个简单的代码版本,它似乎阻止了excel的崩溃。
Private Sub CommandButton1_Click()
Dim sheet_name As String
Dim oShape As Shape
Alert.Rows("15:" & Alert.Rows.count).ClearContents
Alert.Activate
DoEvents
For Each oShape In Alert.Shapes
If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
oShape.Delete
End If
Next
Dim i As Integer, sht As String
DoEvents
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
sht = ListBox1.List(i)
End If
Next i
Application.EnableEvents = False
Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value
Application.EnableEvents = False
Sheets(sht).Delete
Alert.Name = sht
Application.EnableEvents = False
DoEvents
With Alert.Range("L5:L10")
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
DoEvents
With Alert.Range("L2:L3")
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.EnableEvents = True
End Sub