列全体にVBA RIGHTを適用する - 無限ループ問題

Question

Outlookで送信された承認メールからインポートしたデータを解析するためのデータがあります。この時点で、CreationTimeとSubjectLineをインポートしています。

私はスプリット機能を使用して大部分のデータを分離することができます。次に、「ジョブコード：XXXX」と4桁のジョブコード番号と「PN XXXX」というテキストと4桁または6桁の位置番号のいずれかを含む列Bのジョブコードと列Cの位置番号が残されています。右の機能を使用して列全体をループし、列Bの4桁のジョブコード番号と、列Cの4桁または6桁の位置番号（実際の番号）のみを表示するように列を再フォーマットしようとしています。

ジョブコード列Bの場合

： 現在、私のコードは、ジョブ・コードを短縮するために動作しますが、それは、値として式をコピーして貼り付け、短縮ジョブコードのために、その列の右の式を入れて、列を追加する必要が元の列を削除します。

問題 - 作品おそらくない大きなデータセットで最も効率的な（現在は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： 現在、私は上記のコードを反映していますが、文字が8より小さいかどうかを調べるためにLENを使用してif文を追加しました。他のRIGHT機能を挿入してください。これには、追加の列を追加して、その列にRIGHT式を配置し、短縮された位置番号（数だけを除く）を作成し、数式をコピーして値を列に戻してから元の列を削除します。

問題 - これは動作しますが、処理には永遠にかかるようで、実際は無限ループのようです。私はそれをエスケープするとき、それは列を追加し、適切な右の数式（数値だけを残して）を入力しますが、決して終わるように見えることも、コピーして値として数式を貼り付けたり、元の列を削除したりしません。上記のように、これはこれを行うためのより効率的な方法である可能性が高いと認識していますが、私は幸運なしにたくさんのオプションを試しました。

私は、ループ全体が列全体であることが原因である可能性があると認識していますが、最後の行で停止する方法は見つけられません。

コード：

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

ここでコードを高速化するためにできることがいくつかあります。私は最初のコードブロックに同様のロジックを適用できるので、2番目のコードブロックのみを参照します。

最初の問題は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

これを試してください。評価し、ループも追加した列も使用しません。

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