清理凌亂的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公式

回答

相關問題