Vba 宏运行-但不是很好，excel通常崩溃（连同我的整个电脑）

显然，我对VBA真的很陌生-这是我的第一个宏（我做了一个爆炸式的宏），但它运行非常糟糕，每次都崩溃。你有什么建议可以让它更高效地运行吗

PS-我需要执行特殊的粘贴/查找替换（£），因为有一个stange错误，其中空白单元格（有公式）在操作中被粘贴为非空白单元格

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

---

我不能确定，但我猜以下可能是解决您的“崩溃”问题的快速方法

更改：

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

到

---

事实上，我必须感谢你的这篇文章，因为这是一个最好的例子，为什么人们应该总是尽量避免

Do。。。循环

（如果可能的话）。这类循环将永远持续下去，并且每当

子句中的“退出点”选择不当时，Excel就会崩溃。在这种情况下，您的意思是它应该继续运行，直到
ActiveCell
的值为
No
。但是，您忘记了下一个可用的单元格可能不包含
No
，而是不包含任何内容。因此，如果这个循环超出了您的数据网格（
UsedRange
），那么它将继续查找
No
，甚至在第1048576行及更远处。这很容易使您的Excel崩溃。
看起来您要求它反复做同样的事情。当你写“for a=2 to lastrow”时，这意味着它将在这段时间和“next a”之间进行36次。你是有意的吗？它执行36次的其中一项操作是无限循环：“直到活动单元”只选择一个单元，看起来您希望它执行的所有操作都在“循环”之下，这意味着它不会对每个活动单元执行此操作，此外，如果它没有找到“活动单元=否”，它将永远不会结束（无限循环）并使您崩溃

我猜了一下你想要完成什么，但是在循环之后就迷失了方向。我已经编写了一些代码来帮助您开始，并提供了一些注释来帮助您。让我知道你想在循环中做什么，我会尽力帮助你

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

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