Question

我有数据，我正在解析我从Outlook发送的批准电子邮件中导入的数据。此时我只是导入CreationTime和SubjectLine。

对于主题行，我可以使用Split功能分离出大部分数据。然后我留下B栏中的工作代码和C栏中的职位编号，其中包括文字：“工作代码：XXXX”和四位数的工作代码编号和“PN XXXX”以及四位数或6位数的位置编号。我正在尝试使用Right功能循环遍历整个列并重新格式化列，只显示B列的四位数作业代码编号，以及C列的4位数或6位数位数（实际数字）

对于职务代码B列： 目前我的代码适用于缩短作业代码，但它涉及添加一个列，将RIGHT公式放在该列中以缩短作业代码，然后将公式作为值复制并粘贴回列中，然后删除原始列。

问题 - 工作但可能不是最高效的数据集（目前有200行，但会有2000或更多）

代码：

Sub ShortenJobCodes()

Application.ScreenUpdating = False

    Const R4Col = "=RIGHT(RC3,4)"

    Dim oRng As Range
    Dim LastRow As Long

    Range("B1").EntireColumn.Insert

    LastRow = Cells(Rows.Count, "A").End(xlUp).Row

    Set oRng = Range("B:B")
    Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
    Set oRng = Nothing

    Columns("B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues

    Range("C1").EntireColumn.Delete

Application.ScreenUpdating = True

End Sub

对于位置编号C列： 目前我已经镜像了上面的代码，但在if语句中添加了LEN来计算字符是否小于8，如果是，那么如果不插入另一个RIGHT函数则插入一个RIGHT函数。这还涉及添加一个额外的列，将RIGHT公式放在该列中以缩短位置编号（消除所有但只是数字），然后将公式作为值复制并粘贴回列中，然后删除原始列。

问题 - 这可行，但似乎需要永远处理，实际上看起来它处于无限循环中。当我Esc退出它时，它确实添加了列，然后输入了正确的RIGHT公式（仅保留数值）但是sub似乎永远不会结束，也不会将公式复制并粘贴为值或删除原始列。如上所述，我意识到这可能是一种更有效的方法，但我尝试了一堆没有运气的选项。

我意识到循环的一部分可能是因为范围本身就是整个列但是我找不到用最后一行来阻止它的方法（即使我有一个计数）。

代码：

Sub ShortenPositionNumbers()

Application.ScreenUpdating = False

    Const R4Col = "=RIGHT(RC4,4)"
    Const R6Col = "=RIGHT(RC4,6)"

    Dim oRng As Range
    Dim rVal As String
    Dim y As Integer
    Dim selCol As Range
    Dim LastRow As Long

    Range("C1").EntireColumn.Insert

    LastRow = Cells(Rows.Count, "A").End(xlUp).Row

    Set selCol = Range("D:D")

    For Each oRng In selCol
        oRng.Select
        rVal = oRng.Value
        If Len(oRng.Value) > 8 Then
            oRng.Offset(0, -1).FormulaR1C1 = R6Col
        Else
            oRng.Offset(0, -1).FormulaR1C1 = R4Col
        End If
    Next

    Set oRng = Nothing

    Columns("C").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues

    Range("D1").EntireColumn.Delete


Application.ScreenUpdating = True

End Sub

主要问题： 有没有办法使用RIGHT / TRIM / LEN / LEFT函数在单元格中执行此操作，而无需添加列/删除列并插入功能

Answer 1

您可以在此处执行一些操作来加快代码速度。我只会引用第二个代码块，因为您可以将类似的逻辑应用于第一个代码块。

第一个问题是您创建了一个LastRow变量但从未再次引用它。看起来你打算在selCol范围内使用它。您应该将该行更改为Set selCol = Range("C1:C" & lastRow)。这样，当您循环遍历行时，只会遍历已使用的行。

接下来，在For-Each loop你Select你循环的每个单元格中。没有任何理由这样做并且需要更长的时间。然后创建变量rVal但不再使用它。设置循环的更好方法如下。

For Each oRng in selCol
    rVal = oRng.Value
    If Len(rVal) > 8 Then
        oRng.Value = Right(rVal, 6)
    Else
        oRng.Value = Right(rVal, 4)
    End If
Next

这更清晰，不再需要创建列或复制和粘贴。

Answer 2

试试这个，它使用Evaluate，没有循环或添加列。

Sub ShortenPositionNumbers()    
    Application.ScreenUpdating = False

    Dim selCol As Range
    Dim LastRow As Long    

    With ActiveSheet
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
        selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
    End With

    Application.ScreenUpdating = True

End Sub

Answer 3

或使用数组

Sub ShortenPositionNumbers()    
    Dim data As Variant
    Dim i As Long

    With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        data = Application.Transpose(.Value)
        For i = LBound(data) to UBound(data)
            If Len(data(i)) > 8 Then
                data(i) = RIGHT(data(i),6)
            Else
                data(i) = RIGHT(data(i),4)
            End If
        Next
        .Value = Application.Transpose(data)
    End With
End Sub

将VBA RIGHT应用于整个列 - 无限循环问题

3 个答案: