Excel VBA - 我的循环永远存在 - 想法？

Question

我有一张表格，它是将电话帐单的内容复制到 Excel 中的结果。我已经编写了移动费用的代码，它显示在电话号码下方，电话号码旁边。问题是一张标准表中有近 6,000 行需要处理。我想知道是否有比我拥有的更好的方法来移动数据。 谢谢，

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.count, "A").End(xlUp).Row
For X = 2 To LastRow
    If Left(Range("A" & X).Value, 1) = "(" Or Left(Range("A" & X).Value, 1) = "C" Then
        Range("B" & X).Value = Range("A" & (X + 1)).Value
        Range("A" & (X + 1)).Delete
    End If
Next X

基本上它是根据循环查看单元格，如果合适，则将其下方的内容移动到它旁边的单元格并删除生成的空白行。

Answer 1

完全未经测试，因为您没有提供要测试的数据。这假设 A 列中只有数据。

向后迭代，从LastRow - 1 开始（由于是“最后”行，最后一行下面不应有一行电荷）。而不是Delete，我只是Clear，然后在循环结束时使用SpecialCells方法删除所有空单元格（行）。

我修改了识别电话号码单元格的逻辑，假设它们以“C”开头（根据您的逻辑）或格式为 (XXX)-...我认为电话号码可以是由这个逻辑识别：

• 第一个字符 = "("
• 第四和第五个字符 = ")-"

这应该避免误报，因为电话号码和信用都以“（”开头。

Dim thisCell as Range
For X = LastRow - 1 to 2 Step - 1
    Set thisCell = Range("A1" & X)
    'If this cell is a phone number, modify if needed:
    If (Left(thisCell.Value, 1) = "(" And Mid(thisCell.Value,2,4) = ")-") _
       Or Left(thisCell.Value, 1) = "C" Then       
       ' Move what's below it [offset(1,0)] to the adjacent cell [offset(0, 1)]
        thisCell.Offset(0, 1).Value = thisCell.Offset(1, 0).Value
        ' Make the cell beneath empty
        thisCell.Offset(1, 0).Clear
    End If
Next X

' Delete the empty rows:
Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Answer 2

不要删除循环内的行。它会导致多次删除迭代。相反，在循环时创建一个Union（集合）单元格。然后，一旦您的循环完成，立即删除所有单元格的Union。

此外，在这种情况下循环一个范围 (For Each) 将比 For i 循环更快。

---

Sub DeleteMe()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("???")
Dim MyCell As Range, DeleteMe As Range, LRow As Long

LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

For Each MyCell In ws.Range("A2:A" & LRow)
    If Left(MyCell, 1) = "(" Or Left(MyCell, 1) = "C" Then
        MyCell.Offset(, 1).Value = MyCell.Offset(1).Value
        If DeleteMe Is Nothing Then
            Set DeleteMe = MyCell
        Else
            Set DeleteMe = Union(DeleteMe, MyCell)
        End If
    End If
Next MyCell

If Not DeleteMe Is Nothing Then DeleteMe.Delete

End Sub