Abbruchbedingung

Hi, ich habe folgendes Problem:
In einer Excel Tabelle habe ich 2 Sheets in Sheet "Kunde" sollen Abkürzunugen aus einer Zelle durch Langtexte aus Sheet 2 "Shorty" gefüllt werden. Jedoch nur so lange, bis in Sheet "kunde" eine leere Zeile auftaucht. Tja, anbei mal, was ich bisher gemacht habe - in der Variante scheint das Makro allerdings in eine Endlosschleife zu laufen.
Dim wks As Worksheet
Dim rngAll As Range, rngAct As Range
Dim rngShortys As Range
i = 1
Set wks = Worksheets("Shortys")
Set WKS2 = Worksheets("Kunde")
Set rngShortys = wks.Columns("A:A")
Columns("B:B").Select

For Each rngAct In Selection
i = i + 1
If Not IsEmpty(WKS2.Cells(i, 2)) Then
If Not IsError(Application.Match(rngAct, rngShortys, 0)) Then
rngAct = wks.Cells(Application.Match(rngAct, rngShortys, 0), 2)
End If
End If
Next rngAct
Würde ich die BEdingung weglassen, rennt er mir anscheinend alle 64tsd zeilen durch und dass wollte ich verhindern. Vielen Dank schon mal,
Grüße Brent

Hi Brent
Hier ist mein Vorschlag:

Sub Austausch()
    Dim liZeile As Integer, liZeile2 As Integer, liLeer As Integer
    Dim wksKunde As Worksheet, wksShortys As Worksheet

    liZeile = 2
    liZeile2 = 1

    Set wksKunde = Sheets("Kunde")
    Set wksShortys = Sheets("Shortys")

    'wenn wirklich NUR bis zur 1. leeren Zeile ein Wertwechsel stattfinden soll, dann ändere in
    'der nächsten Zeile die 2 in 1
        Do Until liLeer = 2
            If wksKunde.Range("A" & liZeile).Value <> "" Then
                    liLeer = 0
                        Do Until wksShortys.Range("A" & liZeile2).Value = ""
                                If wksShortys.Range("A" & liZeile2).Value = wksKunde.Range("A" & liZeile).Value Then
                                    wksKunde.Range("A" & liZeile).Value = wksShortys.Range("B" & liZeile2).Value
                                    liZeile2 = 1
                                    liZeile = liZeile + 1
                                    Exit Do
                                End If
                            liZeile2 = liZeile2 + 1
                        Loop
                Else
                    liLeer = liLeer + 1
                    liZeile = liZeile + 1
            End If
        Loop
Und hier die Datei zum Testen:
https://www.herber.de/bbs/user/11390.xls
Konnte ich helfen?
Ciao
Thorsten

Forumthread: Abbruchbedingung

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Abbruchbedingung

Forumthread: Abbruchbedingung

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread