Bu Makroyu daha hızlı çalıştırabilir miyim? [çift]

Bu makroyu 1000'den fazla giriş için kullanıyorum. Kodun kendisi istediğim gibi çalışıyor.

Option Explicit
Sub DoTheThing()
 Dim keepValueCol As String
 keepValueCol = "H"

 Dim row As Integer
 row = 2

 Dim keepValueRow As Integer
 keepValueRow = 1

 Do While (Range("E" & row).Value <> "")

    Do While (Range(keepValueCol & keepValueRow).Value <> "")

    Range("E" & row).Value = Replace(Range("E" & row).Value, Range(keepValueCol & keepValueRow).Value, "")
    Range("E" & row).Value = Trim(Replace(Range("E" & row).Value, "  ", " "))

    keepValueRow = keepValueRow + 1
    Loop


 keepValueRow = 1
 row = row + 1
 Loop

End Sub

Yaşadığım sorun Makro'nun sonsuza dek sürmesidir; Size bir fikir vermek gerekirse, bu makro +1000 girişlerde 4 saat boyunca çalışıyor ve ne zaman biteceğini bilmiyorum.

Bu kodun daha hızlı çalışacak ve kodun bütünlüğünden ödün vermeyecek şekilde optimize edilmesinin bir yolu var mı?

Her türlü yardım takdir edilecektir.

Seni anlarsam, H sütunundaki tüm değerleri alıp E sütunundan silmek ister misin? Bunu hızlandırmak için bazı dizilerle yapardım.

Option Explicit
Sub DoTheThing()
Application.ScreenUpdating = False
Dim lastrow As Integer
'Find last row in column H to size our array
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).row

'Declare the array and then resize it to fit column H
Dim varkeep() As Variant
ReDim varkeep(lastrow - 1)

'Load column H into the array
Dim i As Integer
For i = 0 To lastrow - 1
    varkeep(i) = Range("H" & i + 1)
Next

Dim member As Variant
'find last row in column E
lastrow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).row

'loop each cell in column E starting in row 2 ending in lastrow
For i = 2 To lastrow
    'Make a new array
    Dim myArray As Variant
    'Load the cell into the array
    myArray = Split(Cells(i, 5), " ")
    Dim k As Integer
    'for each member of this array
    For k = LBound(myArray) To UBound(myArray)
        member = myArray(k)
        'call the contains function to check if the member exists in column H
        If Contains(varkeep, member) Then
            'if it does, set it to nothing
            myArray(k) = vbNullString
        End If
    Next
    'let's reprint the array to the cell before moving on to the next cell in column E
    Cells(i, 5) = Trim(Join(myArray, " "))
Next
Application.ScreenUpdating = True
End Sub


Function Contains(arr As Variant, m As Variant) As Boolean
    Dim tf As Boolean
    'Start as false
    tf = False
    Dim j As Integer
        'Search for the member in the keeparray
        For j = LBound(arr) To UBound(arr)
            If arr(j) = m Then
                'if it's found, TRUE
                tf = True
                Exit For
            End If
        Next j
        'Return the function as true or false for the if statement
        Contains = tf
End Function

Bu, H sütunundan bir dizi oluşturur. Sonra E sütunundaki her hücreye gider, bir diziye ayrıştırır, bu dizinin her üyesini keep dizisine karşı arar ve bulunursa dizinin o üyesini siler. Hücreden geçtikten sonra, diziyi eksik bulunanlarla yeniden yazdırır.

Diziler genellikle öğeye göre gitmekten daha hızlıdır, ancak ek olarak, yavaş Find and Replace yöntemi kullanmak yerine kendi işlevimizi yaratıyoruz . Tek sorun, verilerde fazladan boşluk bulunması olabilir. Eğer öyleyse, hızlıca bulup bunun için değiştirebiliriz. Diziyi yeniden boyutlandırmak ve öğeleri taşımak yerine dizinin üyelerini hiçbir şey olarak ayarlamayı daha kolay buldum.

Hesaplamaları manuel olarak ayarlamayı denedin mi? (Excel 2013'te)Formulas - Calculation Options - Manual

Amacınız "H" sütunundaki değerlerin tüm oluşumlarını "E" sütunundaki değerlerden kaldırmaktır.

İçeriği dışa aktarmayı ve istediğiniz değişiklikleri gerçekleştirmek için excel dışında bir araç kullanmayı düşündünüz mü?

Kodunuz, H sütununda bulunan değerleri kaldırarak E sütunundaki değerleri güncelliyor, ancak her seferinde yalnızca bir hücreye bakarak verimsiz olarak yapıyor. E sütunundaki tüm aralığı bir kerede ele alarak daha iyi yapabilirsiniz. Ayrıca, tek bir hücreye baksanız bile, sütuna bir dize ve satır için bir sayı birleştirmek yerine erişmek için bir Range nesnesini kullanmak daha kolaydır.

Bu kod sizinkiyle aynı şeyi yapmalıdır, ancak Range nesnesinin Replace yöntemini kullanarak (EI'deki bir Replace yaptığınız ile aynı işlevselliktir) aynı anda E sütunundaki tüm değerleri işler. Bu çok daha hızlı olmalı.

ReplaceAşağıdaki ilk çağrıda True, son argüman için büyük / küçük harfe duyarlı bir eşleşme belirtilir. Büyük / küçük harf duyarlı bir eşleşme istiyorsanız, bunu değiştirin False.

Option Explicit
Sub DoTheThing()

  Dim UpdateRange As Range, ReplaceCell As Range, dummy As Boolean

  Set UpdateRange = Range("E2", Range("E2").End(xlDown))
  Set ReplaceCell = Range("H1")

  Do While (ReplaceCell.Value <> "")
    dummy = UpdateRange.Replace(ReplaceCell.Value, "", xlPart, , True)
    dummy = UpdateRange.Replace("  ", " ", xlPart)
    Set ReplaceCell = ReplaceCell.Offset(1, 0)
  Loop

End Sub

Gösterildiği gibi ekleyin

    if (Range("E"&row).value="") then
      Exit Do
    End if

2 Aralık ("E" ve satır) komutlarından sonra yukarıdakileri ekleyin.

Bu şekilde, değeri NULL ile değiştirdikten sonra, E sütununun geri kalanı için H sütununu aramanın anlamı yoktur. Öyleyse eğer E 2 satırında NULL ise, H sütunundaki 3-1000 sırasını aramanın anlamı yoktur, bu yüzden döngüden ayrılın ve E3'e geçin.

Ayrıca H sütununun sırası kritiktir. Mümkünse, en yaygın eşleşmeler H sütununun en üstünde olmalıdır, bu nedenle listenin sırasız veya rasgele olsaydı, H kadar arama yapması gerekmez.

Partiye geç katılıyorum, ancak iki kuruşumu çözümlere vermek istiyorum.

Bu kod column H(8) 'deki değerleri arayacak ve bunları ""E sütununda değiştirecektir .

E sütunundaki hücreye hücre gitmek yerine, tam sütunda yer değiştirmeyi sağlar, böylece H sütunundaki değerlerde tek bir döngü yapacaktır.

Public Sub big_search()
Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = ThisWorkbook
Set wks = wkb.Sheets(1)
thisrow = 1
existe = True
inicio = Format(Now(), "yyyymmddhhmmss")
While existe
    ' keep in mind that the column H is the 8th
    selectionvalue = wks.Cells(thisrow, 8)
    If selectionvalue <> "" Then
        wks.Columns("E").Replace What:=selectionvalue, Replacement:="", SearchOrder:=xlByColumns, MatchCase:=True
        thisrow = thisrow + 1
    Else
        existe = False
    End If
Wend
fin = Format(Now(), "yyyymmddhhmmss")
a = MsgBox(fin - inicio & " seconds", vbOKOnly)
End Sub