清理凌乱的VBA公式

我对Excel VBA很新颖（大约一天前开始！），但我正在慢慢挣扎。如果列D包含值“（2）”，然后将值“0”分配给同一行中的更多单元格，我创建了一个公式将三个单元格的选择复制到工作表的另一部分。清理凌乱的VBA公式

问题是，我用录音和键入我的宏的混合，所以最终的结果是相当混乱。目前这个宏需要一段时间才能完成（它会移动一切，然后稍微出现一个沙漏15秒左右）。我假设这部分是由于我使用了“选择”（我知道这是一件坏事！），但我只是试图弄清楚我可以从公式中去掉什么，以使它更高效保持相同的结果。

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

任何帮助将不胜感激。

来源

2016-04-15 Antony

非常感谢大家。所有这些都运作良好。从现在开始，我会记得在“代码评审”中对工作代码提出任何问题。 – Antony

绝对将其发送给CR，我们有一个积极的，经验丰富的VBA社区，他们很乐意帮助你。 – Kaz

就像旁边一样，**大幅度提高执行速度的最简单方法是在代码开始处放置Application.ScreenUpdating = False Application.EnableEvents = False，然后将它们设置回True。在代码的最后。 – Kaz

试试这个

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

来源

2016-04-15 13:13:52

给这个镜头，你可以通过结合多个偏移量和范围来清理它。

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

来源

2016-04-15 12:58:06 Will

而是在D列打算通过量每个单元格的，你可以通过只使用的范围，就像这样：

Set SrchRng = Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)

这应该加快步伐相当多。

您可以使用Select，我发现在我自己学习VBA时更容易。及时你会学会避免它。要在使用Select时加快宏执行速度，您可以在开始处添加Application.ScreenUpdating = False，在步骤结束时添加Application.ScreenUpdating = True。
禁用自动计算也是有益的，您可以通过分别在开始和结束时分别添加Application.Calculation = xlManual和Application.Calculation = xlManual来完成。

希望有所帮助。如果你有更多的问题，请问。

来源

2016-04-15 13:08:50

如果我理解你想要做什么，这应该做同样的事情，而不必使用任何物体或任何复制/粘贴方法：

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

更重要的是，如果你的代码正在工作，并且你只是想要改进建议，那么你应该在Code Review上发布你的代码，而不是堆栈溢出。

来源

2016-04-15 13:15:37

轮到我了 - 不是看每个单元格，而是跳转到包含（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

来源

2016-04-15 13:30:20

清理凌乱的VBA公式

回答

相关问题