将VBA RIGHT应用于整个列 – 无限循环问题
我有数据，我正在parsing，我从Outlook中发送的批准电子邮件中导入。 在这一点上，我只是导入CreationTime和SubjectLine。
对于主题行我可以使用拆分function分离出大部分数据。 然后，我的工作代码列在B列，职位编号列在C列，其中包括文本：“工作代码：XXXX”和四位工作代码编号和“PN XXXX”以及四位或六位数字的位置编号。 我正在尝试使用正确的function来遍历整个列并重新格式化列，只显示列B的四位数作业代码编号，而列C的四位或六位数位置编号（实际编号）
对于作业代码栏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，如果是的话插入一个RIGHTfunction，如果不插入其他RIGHTfunction。 这还涉及添加一个额外的列，将RIGHT公式放在该列中缩短的位置编号（删除所有，但不仅仅是数字），然后将公式作为值复制并粘贴回列，然后删除原始列。
问题 – 这种方法有效，但似乎需要永久处理，事实上看起来像在一个无限循环中。 当我退出它时，它会添加列，然后input正确的RIGHT公式（只留下数字值），但是子永远不会结束，也不会复制和粘贴公式作为值或删除原始列。 如上所述，我意识到这可能是一个更有效的方法来做到这一点，但我已经尝试了一堆选项，没有任何运气。
我意识到循环的一部分可能是由于范围本身是一个整列，但我无法find一种方法来阻止最后一行（即使我有一个计数在那里）。
码：
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函数在单元格内执行此操作，而无需添加列/删除列和插入函数？
有几件事你可以在这里加快你的代码。 我只会引用第二个代码块，因为您可以将类似的逻辑应用到第一个代码块。
第一个问题是，你创build一个LastRowvariables，但不要再引用它。 它看起来像你打算在selCol范围内使用这个。 您应该将该行更改为Set selCol = Range("C1:C" & lastRow) 。 这样，当你循环遍历行时，你只能遍历使用过的行。
接下来，在For-Each loop ， Select For-Each loop每个单元格。 真的没有什么理由要这样做，而且需要更长的时间。 然后创buildvariablesrVal但不再使用它。 build立循环的更好方法如下。
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
这是更清洁，不再需要创build列或复制和粘贴。
试试这个，它使用评估和没有循环或添加列。
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
或者使用数组
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