エクセル2010は、ループ

Question

私が終了する前に15万反復を実行するように設計されたマクロを（下）持っているのXの数よりも多くの後にクラッシュし。ただし、繰り返し回数が1,000回を超えるコードを実行すると、Excelは「応答しない」モードに移行し、クラッシュします。私は12時間以上それを残しましたが、それ以上は良くなりません。このコードは以前は最初の100,000回の反復を実行するために使用されていましたが、250,000回の段階で1,048,576回の反復を実行する必要があります。

クラッシュ（私はそれらを同時に実行を停止しましたが、それでもクラッシュ）も見通し、IEだけでなく、Chromeをダウンさせます。

私はF5を経由してF8を経由して、またはチェックポイントにコードを実行すると、コードが細かい実行されます。しかし、これは948,576回繰り返すと実用的ではありません。

それは常にクラッシュしないように、問題を解決する方法上の任意の提案？

システムの仕様は以下のとおりです。 エクセル2010 のi5（第三世代） 8ギガバイトのRAM

コード：これはちょうど12のうち10列を移入するために私に5秒未満を取った

Dim a As Variant 
Dim b As Variant 
Dim c As Variant 
Dim d As Variant 
Dim e As Variant 
Dim i As Integer 
Dim j As Double 
Dim strResult As Double 

a = 1 
b = 100001 

While b <= 250000 

    While a <= 12 

     If a = 1 Then 

      If Cells(b, 14) = "EEEE" Then 
       Cells(b, a) = 1234 
      ElseIf Cells(b, 14) = "ZYXW" Then 
       Cells(b, a) = 2468 
      ElseIf Cells(b, 14) = "AAAA" Then 
       Cells(b, a) = 3579 
      ElseIf Cells(b, 14) = "BBBB" Then 
       Cells(b, a) = 9764 
      ElseIf Cells(b, 14) = "DDDD" Then 
       Cells(b, a) = 8631 
      Else 
       Cells(b, a) = "ZZZZ" 
      End If 

     ElseIf a = 2 Then 

      If Cells(b, 15) = 5 Then 
       Cells(b, a) = "JPY" 
      ElseIf Cells(b, 15) = 4 Then 
       Cells(b, a) = "GBP" 
      ElseIf Cells(b, 15) = 3 Then 
       Cells(b, a) = "CHF" 
      ElseIf Cells(b, 15) = 2 Then 
       Cells(b, a) = "USD" 
      ElseIf Cells(b, 15) = 1 Then 
       Cells(b, a) = "EUR" 
      Else 
       Cells(b, a) = "YYYY" 
      End If 

     ElseIf a = 3 Then 

      If Cells(b, 16) = 10234 Then 
       Cells(b, a) = "A27Z2" 
      ElseIf Cells(b, 16) = 10420 Then 
       Cells(b, a) = "B28Y" 
      ElseIf Cells(b, 16) = 10432 Then 
       Cells(b, a) = "C29X" 
      ElseIf Cells(b, 16) = 18953 Then 
       Cells(b, a) = "D30W" 
      ElseIf Cells(b, 16) = 21048 Then 
       Cells(b, a) = "E31V" 
      ElseIf Cells(b, 16) = 36542 Then 
       Cells(b, a) = "F32U" 
      ElseIf Cells(b, 16) = 36954 Then 
       Cells(b, a) = "G33T" 
      ElseIf Cells(b, 16) = 65425 Then 
       Cells(b, a) = "H34S" 
      ElseIf Cells(b, 16) = 75963 Then 
       Cells(b, a) = "I35R" 
      ElseIf Cells(b, 16) = 84563 Then 
       Cells(b, a) = "J36Q" 
      Else 
       Cells(b, a) = "XXXX" 
      End If 

     ElseIf a = 4 Then 

      strResult = 1 
      For i = 1 To Len(Cells(b, 18)) 
       Select Case Asc(Mid(Cells(b, 18), i, 1)) 
        Case 65 To 90: 
         strResult = strResult + Asc(Mid(Cells(b, 18), i, 1)) - 64 
        Case Else 
         strResult = strResult + Mid(Cells(b, 18), i, 1) 
       End Select 
      Next 

      j = WorksheetFunction.CountIfs(Range("A1:A" & b), Range("A" & b), Range("B1:B" & b), Range("B" & b)) 

      Cells(b, a) = Cells(b, 1) & " - " & Cells(b, 2) & strResult & " - " & j 

     ElseIf a = 5 Then 

      Cells(b, a) = Cells(b, 17) 

     ElseIf a = 6 Then 

      If Cells(b, 19) = "SB" Then 
       Cells(b, a) = "Sub" 
      ElseIf Cells(b, 19) = "RD" Then 
       Cells(b, a) = "Red" 
      Else 
       Cells(b, a) = "XXXX" 
      End If 

     ElseIf a >= 7 Then 

      Cells(b, a) = Cells(b, a + 13) 

     End If 

     a = a + 1 

    Wend 

    b = b + 1 
    a = 1 

Wend 

    Columns("M:Q").Select 
    Selection.Delete Shift:=xlToLeft 
    Columns("N:V").Select 
    Selection.Delete Shift:=xlToLeft 

Answer 1

これは私がコメントで先に述べたバリアント、インメモリ処理であるが得たものです。実際には、以前に提供された数式アプローチが少し遅くなっていますが、より完全です。特に辞書オブジェクトを使用してカウントを計算する。

Option Explicit 

Sub bigRun() 
    Dim a As Long, b As Long, i As Long, j As Long 
    Dim c As Variant, d As Variant, e As Variant '<~~?????? 
    Dim vals As Variant 
    Dim ab As String, strResult As String 
    Dim dABs As Object 

    appTGGL 

    Set dABs = CreateObject("Scripting.Dictionary") 
    dABs.CompareMode = vbTextCompare 

    With Worksheets("Sheet1") 
     vals = .Range("A100001:Z250000").Value2 
     For b = 100001 To 250000 
      For a = 1 To 12 
       Select Case a 
        Case 1 
         Select Case vals(b - 100000, 14) 
          Case "EEEE" 
           vals(b - 100000, a) = 1234 
          Case "ZYXW" 
           vals(b - 100000, a) = 2468 
          Case "AAAA" 
           vals(b - 100000, a) = 3579 
          Case "BBBB" 
           vals(b - 100000, a) = 9764 
          Case "DDDD" 
           vals(b - 100000, a) = 8631 
          Case Else 
           vals(b - 100000, a) = "ZZZZ" 
         End Select 
        Case 2 
         Select Case vals(b - 100000, 15) 
          Case 5 
           vals(b - 100000, a) = "JPY" 
          Case 4 
           vals(b - 100000, a) = "GBP" 
          Case 3 
           vals(b - 100000, a) = "CHF" 
          Case 2 
           vals(b - 100000, a) = "USD" 
          Case 1 
           vals(b - 100000, a) = "EUR" 
          Case Else 
           vals(b - 100000, a) = "YYYY" 
         End Select 
        Case 3 
         Select Case vals(b - 100000, 16) 
          Case 10234 
           vals(b - 100000, a) = "A27Z2" 
          Case 10420 
           vals(b - 100000, a) = "B28Y" 
          Case 10432 
           vals(b - 100000, a) = "C29X" 
          Case 18953 
           vals(b - 100000, a) = "D30W" 
          Case 21048 
           vals(b - 100000, a) = "E31V" 
          Case 36542 
           vals(b - 100000, a) = "F32U" 
          Case 36954 
           vals(b - 100000, a) = "G33T" 
          Case 65425 
           vals(b - 100000, a) = "H34S" 
          Case 75963 
           vals(b - 100000, a) = "I35R" 
          Case 84563 
           vals(b - 100000, a) = "J36Q" 
          Case Else 
           vals(b - 100000, a) = "XXXX" 
         End Select 
        Case 4 
         ab = Join(Array(vals(b - 100000, 1), vals(b - 100000, 2)), ChrW(8203)) 
         If dABs.exists(ab) Then 
          j = dABs.Item(ab) + 1 
         Else 
          j = 1 
         End If 
         dABs.Item(ab) = j 

         strResult = 1 
         For i = 1 To Len(vals(b - 100000, 18)) 
          Select Case Asc(Mid(vals(b - 100000, 18), i, 1)) 
           Case 65 To 90: 
            strResult = strResult + Asc(Mid(vals(b - 100000, 18), i, 1)) - 64 
           Case Else 
            strResult = strResult + Mid(vals(b - 100000, 18), i, 1) 
          End Select 
         Next 

         vals(b - 100000, a) = Join(Array(vals(b - 100000, 1), _ 
                 vals(b - 100000, 2), _ 
                 strResult, j), _ 
                Chr(32) & Chr(45) & Chr(32)) 
        Case 5 
         vals(b - 100000, a) = vals(b - 100000, 17) 
        Case 6 
         Select Case vals(b - 100000, 19) 
          Case "SB" 
           vals(b - 100000, a) = "Sub" 
          Case "RD" 
           vals(b - 100000, a) = "Red" 
          Case Else 
           vals(b - 100000, a) = "XXXX" 
         End Select 
        Case 7 To 12 
         vals(b - 100000, a) = vals(b - 100000, a + 13) 
       End Select 
      Next a 
     Next b 

     .Range("A100001").Resize(UBound(vals, 1), UBound(vals, 2)) = vals 

     '.Columns("M:Q").Delete Shift:=xlToLeft 
     '.Columns("N:V").Delete Shift:=xlToLeft 

    End With 

    dABs.RemoveAll: Set dABs = Nothing 
    appTGGL bTGGL:=False 

End Sub 

Public Sub appTGGL(Optional bTGGL As Boolean = True) 
    With Application 
     .ScreenUpdating = bTGGL 
     .EnableEvents = bTGGL 
     .DisplayAlerts = bTGGL 
     .Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual) 
    End With 
    Debug.Print Timer 
End Sub 

私のサンプルデータが一時的にhere可能です。自分の設定を密接に反映している古いi5ビジネスクラスのノートパソコンの経過時間は約13秒でした。

Answer 2

。それは私のシートの大部分が空であったが、計算/スクリーン更新をオフにするとそれほど速くないからである。それは移入されません

唯一の2つの列がCとDです。条件式の条件を満たしているため、数式アプローチを使用することはできません。あなたはこれらの2

行100001から250000へと列1から12にループする必要はありません用の小さなループを書くことができます。それらのセルに数式を一度に入力することができます。私はこのコードを実行したときにここでは一例

Sub Sample() 
    '~~> When a = 1 i.e Col A 
    range("A100001:A250000").Formula = "=IF(N100001=""EEEE"",""1234"",IF(N100001=""ZYXW"",""2468"",IF(N100001=""AAAA"",""3579"",IF(N100001=""BBBB"",""9764"",IF(N100001=""DDDD"",""8631"",""ZZZZ"")))))" 

    range("B100001:B250000").Formula = "=IF(O100001=""5"",""JPY"",IF(O100001=""4"",""GBP"",IF(O100001=""3"",""CHF"",IF(O100001=""2"",""USD"",IF(O100001=""1"",""EUR"",""YYYY"")))))" 

    '3,4 This needs to be coded 

    range("E100001:E250000").Value = range("Q100001:Q250000").Value 

    range("F100001:F250000").Formula = "=IF(S100001=""SB"",""Sub"",IF(S100001=""RD"",""Red"",""XXXX""))" 

    For i = 7 To 12 
     range(Cells(100001, i), Cells(250000, i)).Formula = "=" & Cells(100001, i + 13).Address 
    Next i 
End Sub 

で、これは私が