Question

我是Excel VBA的新手（大约一天前开始！）但我正在慢慢地奋斗。我创建了一个公式，如果列D包含值“（2）”，则将三个单元格的选择复制到工作表的另一部分，然后将值“0”分配给同一行中的某些单元格。

问题是，我使用了录制和输入宏的混合物，因此最终结果非常混乱。目前，宏需要一段时间才能完成（它会移动一切，然后会出现一点沙漏，持续15秒左右）。我假设这部分是由于我使用“选择”（我知道这是一件坏事！）但我只想弄清楚我可以从公式中剥离什么来使其更有效率保持相同的结果。

{{1}}

非常感谢任何帮助。

Answer 1

如果我理解你正在尝试做什么，这应该做同样的事情，而不必使用任何对象或任何复制/粘贴方法：

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上发布代码，而不是在Stack Overflow上发布。

Answer 2

给它一个镜头，你可以通过组合多个偏移和范围来更好地清理它。

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

Answer 3

不是通过列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。

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

Answer 4

试试这个

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

Answer 5

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

清理凌乱的VBA公式

5 个答案: