nested for loop - simplere måde?

Hej,

jeg har fået løst følgende problem:

Jeg har en liste af DSL numre (numre som starter med teksten "DSL") - sammen med andre numbre: VPN, WMX osv..
(Problemet var at alle DSL numrene havde dubletter- somme tider var der 2 forekomster af samme tal, somme tider op til 7)

jeg skulle så lede igennem den liste for at finde kun DSL numrene, smide dem over fra ark1 til ark3 (kolonne A)..

Så skulle jeg tjekke hele kolonne A i ark3, om det samme tal (som er i den celle, mit for loop kører igennem) findes i kolonne B.. hvis ikke (blnMatch = False), smid da det tal over i kolonne B..
(Så vil det næste tal - hvis det er det samme som tallet før - blive fundet i kolonne B og der: blnMatch = True)

..

det her virker fint, men det arbejder utroligt langsomt.. det bruge 5 sekunder på at finde ca. 42 tal - som vil sige at alt i alt (igennem 8801 tal) vil det tage 17 minutter?

er der nogen der ved en hurtigere måde?

koden er som følge:

---
Option Explicit

Private Sub Worksheet_Activate()
    Dim intI As Integer
    Dim intJ As Integer
    Dim intK As Integer
    Dim arrDSL() As String
    Dim arrNew(1 To 5634) As String
    Dim strDSL As String
    Dim blnMatch As Boolean
   
    For intI = 1 To 8801
        strDSL = strDSL & ThisWorkbook.Sheets(1).Cells.Range("A" & intI) & " "
    Next intI
    arrDSL = Split(strDSL, " ")
   
    intJ = 0
   
   
    ThisWorkbook.Sheets(3).Cells.Range("A1") = "Processing numbers..."
    For intI = LBound(arrDSL) To UBound(arrDSL)
        ThisWorkbook.Sheets(3).Cells.Range("A" & intI + 2) = arrDSL(intI)
    Next intI
   
    For intI = LBound(arrDSL) To UBound(arrDSL)
        If (Mid(arrDSL(intI), 1, 4) = "DSL5") Then
            intJ = intJ + 1
            arrNew(intJ) = arrDSL(intI)
            ThisWorkbook.Sheets(3).Cells.Range("A" & intI + 1) = ""
        End If
    Next intI
   
   
    For intI = LBound(arrNew) To UBound(arrNew)
        ThisWorkbook.Sheets(3).Cells.Range("A" & intI + 1) = arrNew(intI)
    Next intI
   
    blnMatch = False
    intK = 2
   
    For intI = LBound(arrNew) To UBound(arrNew)
        With ThisWorkbook.Sheets(3).Cells
            For intJ = 1 To 3636
                If (arrNew(intI) = .Range("B" & intJ)) Then
                    blnMatch = True
                End If
            Next intJ
            If (blnMatch = False) Then
                .Range("B" & intK) = arrNew(intI)
                intK = intK + 1
            End If
        End With
        blnMatch = False
    Next intI
   
    ThisWorkbook.Sheets(3).Cells.Range("A1") = "Processing complete!"
End Sub
---


På forhånd tak,

// jih