Question

显然我对VBA很新 - 这是我的第一个Macro（而且我有一个爆炸），但它运行得非常糟糕并且每次都崩溃。您是否有任何关于如何使其更有效运行的提示？

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

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（如果可能的话）。这种循环会永远持续下去，只要until子句中的“退出点”选择不当，就会导致Excel崩溃。在这种情况下，您要说它应该继续运行，直到ActiveCell的值为No。然而，您忘记了下一个可用的单元格可能不包含No但是没有任何内容。因此，如果此循环超出了您的数据网格（UsedRange），则即使在行1,048,576及更高版本中，它仍会继续查找No。这很容易导致Excel崩溃。

Answer 2

看起来你要求它一遍又一遍地做同样的事情。当你写'for a = 2 to lastrow'时，这意味着它将进入那个和'next a'之间的所有东西，在这个例子中，36次。你的意思是这样吗？其中36次做的事情之一是无限循环：'直到活动单元'才选择一个单元格，看起来你想要它做的一切都在'循环'之下，这意味着它不会对每个活动单元执行，另外，如果它没有找到'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

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

2 个答案: