macros运行 – 但不是很好，和Excel通常崩溃（连同我的整个PC）

显然，我对VBA真的很陌生 – 这是我的第一个macros（我有一个爆发），但它运行非常糟糕，每次崩溃。 你有什么技巧可以让我更有效地运行吗？

PS – 我需要做特殊的粘贴/findreplace（£），因为空白单元格（有公式）被粘贴为非空白的操作错误

Sub DTC_Generator() Application.EnableEvents = False 'Prevents screen from moving through cells/events' Application.ScreenUpdating = False 'Prevents screen from tabbing' Application.CutCopyMode = False 'prevents gray residue after copy/paste' Application.DisplayStatusBar = False 'LOOP RANGE Dim A As Integer Lstrow = Sheet4.Range("A" & Rows.Count).End(xlUp).Row For A = 2 To Lstrow Sheet4.Activate Range("A2").End(xlDown).Select Lstrow = ActiveCell.Row Cells(A, 1).Copy Range("L1").Activate ActiveCell.PasteSpecial Paste:=xlPasteValues 'BEGIN MACRO 'PASTE PRE-GENERATOR ATTRIBUTES Sheet4.Activate Range("AA2:AL36").Delete Range("M2:X36").Copy Range("AA2:AL36").PasteSpecial Paste:=xlPasteValues Range("AA2:AL36").Copy Sheet7.Activate Range("A2").PasteSpecial Paste:=xlPasteValues Range("A2:AL36").Select Selection.Replace What:="", Replacement:="£", LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("A2:AL36").Select Selection.Replace What:="£", Replacement:="", LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False 'DElETE OLD DATA 'SELECT ATTRIBUTE DATA Sheet7.Activate Range("M2").Select 'Loops through unique values until "no" Do Until ActiveCell = "No" ActiveCell.Offset(1, 0).Select Loop 'bumps it back 1 row and over 19 columns' ActiveCell.Offset(-1, 19).Select ActiveCell.Name = "Bottom_Left" Range("BH2:Bottom_Left").Copy 'PASTE INTO ATTRIBUTE INPUT FILE' Sheet2.Activate Range("A:A").End(xlDown).Offset(1, 0).Select Lastrow = ActiveCell.Row Cells(Lastrow, 1).PasteSpecial Paste:=xlPasteValues Next A MsgBox ("success?") End Sub 

Answer 1

我不能确定，但​​我猜测以下可以快速解决您的“崩溃”问题。

更改：

 Do Until ActiveCell = "No" ActiveCell.Offset(1, 0).Select Loop 

至

 Do Until ActiveCell.Value2 = "No" or ActiveCell.Value2 = vbNullString ActiveCell.Offset(1, 0).Select Loop 

其实我不得不感谢你这个职位，因为这是一个总是试图避免Do ... Loop （如果可能的话）的Do ... Loop 。 这些types的循环会一直持续下去，并且只要在until子句中的“退出点”select不当，就有崩溃的倾向。 在这种情况下，你说它应该继续前进，直到ActiveCell值为No 。 然而，你忘了下一个可用的单元格可能不包含No但没有任何内容。 所以，如果这个循环超出了你的数据网格（ UsedRange ），那么即使在第1,048,576行以后，它也会继续寻找No 这可能会轻易导致您的Excel崩溃。

Answer 2

看起来你要求它一遍又一遍地做同样的事情。 当你写'为a = 2拉斯特罗'，这意味着它将在这个和下一个a之间的所有事情，在这种情况下，36次。 你有意要这样做吗？ 它做的36次是一个无限循环：“直到活动单元格”才select一个单元格，它看起来像你想要做的所有事情都在“循环”之下，这意味着它不会对每个活动单元格执行它，另外，如果它没有find“active cell = no”，它将永远不会结束（无限循环）并使你崩溃。

我猜测你想要完成什么，但是在循环之后却迷失了方向。 我写了一些代码让你开始和评论来帮助你。 让我知道你在循环中试图做什么，我会尽力帮助。

 Sub DTC_Generator() Application.EnableEvents = False 'Prevents screen from moving through cells/events' Application.ScreenUpdating = False 'Prevents screen from tabbing' Application.CutCopyMode = False 'prevents gray residue after copy/paste' Application.DisplayStatusBar = False Sheet4.Name = "DTC_Generator" 'by naming the sheet you can work 'with' it, 'thereby making the code specific to this workbook so if you have other workbooks open it will not get confused 'about which workbook it's processing 'avoid selecting and activating if at all possible, saves time/cpu resources Dim A As Long 'integer is limited in its length, just go ahead and always use Long for numbers Dim Lastrow1 As Long Dim Lastrow2 As Long Dim Lastrow As Long Dim x As Variant With ThisWorkbook With .Sheets("DTC_Generator") 'seems like the data you want to use is in columns M:X so goon base last row on those Lastrow1 = .Range("M" & Rows.Count).End(xlUp) Lastrow2 = .Range("X" & Rows.Count).End(xlUp) If Lastrow2 > Lastrow1 Then Lastrow = Lastrow2 Else Lastrow = Lastrow1 .Cells.ClearFormats 'remove if you need to keep formats .Cells.Copy 'get more specific if you need to keep formulas .Range("A1").PasteSpecial xlPasteValues .Columns("A").Value = .Columns("A").Value 'this does the whole column at once, no need to loop through each cell .Range("L1").Value = .Range("A2").Value 'you were doing this for each cell in column A, doesn't seem right so I moved it here but you can move it if you need to 'you were also recalculating your lastrow for every cell in A .Range("M2:X" & Lastrow).Copy .Range("AA2").PasteSpecial xlPasteValues Application.CutCopyMode = False 'you don't need to move it to a separate sheet to clean it up 'you may not need to do this at all, uncomment if you do '.Columns("AA:AAL").Replace What:="", Replacement:="£", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '.Columns("AA:AAL").Replace What:="£", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 'this is better than a loop cuz it will def just do the range so an infinite loop won't happen and crash you 'i think your "Do Until ActiveCell = "No"" was meant to loop through M2:X36, if so, do this For Each x In Range(.Range("M2"), .Range("M" & Rows.Count).End(xlUp)) '*************************************************** 'YOU LOST ME AFTER THIS - WHAT ARE YOU TRYING TO DO? '*************************************************** Next x End With End With 'be sure to turn stuff back on Application.EnableEvents = True Application.ScreenUpdating = True Application.DisplayStatusBar = True MsgBox "success?" End Sub