清理杂乱的VBA公式
我对Excel VBA非常陌生（大约一天前开始！），但是我正在慢慢挣扎。 如果列D包含值“（2）”，然后将值“0”分配给同一行中的更多单元格，我已经创build了一个公式，可以将选中的三个单元格复制到工作表的另一部分。
麻烦的是，我用了混合录音和打字我的macros，所以最终的结果是相当混乱。 目前macros需要一段时间才能完成（它会移动所有东西，然后稍微出现一个沙漏15秒左右）。 我假设这部分是由于我使用“select”（我知道这是一件坏事！），但我只是试图找出我可以从公式中删除什么，使其更有效保持相同的结果。
Sub MoveNames() Dim SrchRng As Range, cel As Range Set SrchRng = Range("D:D") For Each cel In SrchRng If InStr(1, cel.Value, "(2)") > 0 Then cel.Offset(0, 1).Range("A1:C1").Select Selection.Copy ActiveCell.Offset(-1, 40).Range("A1").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveCell.Offset(0, -4) = "0" ActiveCell.Offset(0, -5) = "0" ActiveCell.Offset(0, -6) = "0" ActiveCell.Offset(0, -7) = "0" ActiveCell.Offset(0, -10) = "0" ActiveCell.Offset(0, -12) = "0" End If Next cel End Sub 任何帮助将非常感激。
尝试这个
Sub MoveNames() Dim SrchRng As Range lastrow = Range("D" & Rows.Count).End(xlUp).Row Set SrchRng = Range("D1:D" & lastrow) For Each cel In SrchRng If InStr(1, cel.Value, "(2)") > 0 Then With cel.Offset(0, 1).Range("A1:C1") .Copy cel.Offset(-1, 40).Range("A1") End With With cel.Offset(-1, 40) .Offset(0, -4) = "0" .Offset(0, -5) = "0" .Offset(0, -6) = "0" .Offset(0, -7) = "0" .Offset(0, -10) = "0" .Offset(0, -12) = "0" End With End If Next cel End Sub
如果我明白你想要做什么，这应该做同样的事情，而不必使用任何对象或任何复制/粘贴方法：
Sub MM_MoveNames() For i = 2 To Cells(Rows.count, 4).End(xlUp).Row If InStr(Cells(i, 4).value, "(2)") Then Cells(i - 1, 44).Resize(1, 3).value = Cells(i, 5).Resize(1, 3).value Cells(i, 37).Resize(1, 4).value = 0 Cells(i, 34).value = 0 Cells(i, 32).value = 0 End If Next End Sub
更重要的是，如果你的代码正在工作，而你只是想要改进的build议，那么你应该在Code Review上发布你的代码，而不是在Stack Overflow上。
给这个镜头，你可以通过结合多个偏移量和范围来清理它。
Sub test() Dim rngIndex As Range For Each rngIndex In Range("D:D") If InStr(1, rngIndex.Value, "(2)") > 0 Then rngIndex.Offset(0, 1).Range("A1:C1").Copy _ rngIndex.Offset(0, 1).Range("A1:C1").Offset(-1, 40).Range("A1") With rngIndex.Offset(0, 1).Range("A1:C1") Range(.Offset(0, -4), .Offset(0, -7)).Value = 0 .Offset(0, -10) = "0" .Offset(0, -12) = "0" End With End If Next rngIndex End Sub
而不是通过列D每个单元格，您可以通过使用的范围，如下所示：
Set SrchRng = Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)
这应该加快一点。
你可以使用Select ，我发现在我自己学习VBA的时候更容易。 及时你将学会避免它。 要在使用Select时加快macros执行速度，可以在开始时添加Application.ScreenUpdating = False ，在过程结束时添加Application.ScreenUpdating = True 。
禁用自动计算也是有益的，你可以通过在开始和结束分别添加Application.Calculation = xlManual和Application.Calculation = xlManual完成。
希望有所帮助。 如果你有更多的问题，请问。
轮到我 – 而不是看每个单元格，只是跳到包含（2）的单元格。
Sub MoveNames() Dim SrchRng As Range, cel As Range Dim rFound As Range Dim sFirstAddress As String Set SrchRng = ThisWorkbook.Worksheets("Sheet1").Range("D:D") Set rFound = SrchRng.Find("(2)", LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext) If Not rFound Is Nothing Then sFirstAddress = rFound.Address Do rFound.Offset(, 1).Resize(, 3).Copy Destination:=rFound.Offset(-1, 41) rFound.Offset(-1, 34).Resize(, 4) = 0 rFound.Offset(-1, 29) = 0 rFound.Offset(-1, 31) = 0 Set rFound = SrchRng.FindNext(rFound) Loop While Not rFound Is Nothing And rFound.Address <> sFirstAddress End If End Sub