Fehler im Makro zum bedingten kopieren von Zellen

Question

Hallo zusammen,

ich habe mal wieder ein Problem mit Excel, das ich versucht habe zu lösen. Leider ist mir dies aufgrund meiner geringen VBA Kenntnisse nicht gelungen.
Es handelt sich um folgendes Problem:
Mittels eines Makros sollen die Zellwerte von A1:A340 einer Tabelle (hier Tabelle 26) kopiert und in eine bestehende Tabelle (Tabelle 23) kopiert werden.
Soweit funktioniert es.
Alle Zellen des zu kopierenden Bereichs enthalten Formeln (WENN DANN Funktionen hauptsächlich). Bei einigen Zellen ist das Formelergebnis nichts (""), so dass eine leere Zelle vorhanden ist.
Diese "leeren" Zellen sollen nicht mitkopiert werden, bzw. beim kopieren gelöscht werden, so dass in der Tabelle 23 eine Liste ohne die leeren "Formelzellen" erscheint.
Dazu habe ich mir das folgende Makro gebastelt:

Sub TaballeohneLeerekopieren()
On Error Resume Next
Dim i As Integer
ThisWorkbook.Worksheets("Tabelle26").Activate
Sheets("Tabelle26").Range("A1:A344").Copy Destination:=Sheets("Tabelle21").Range("A1")



Application.ScreenUpdating = False
Sheets("Tabelle21").Activate
Range("A1:A344").Select
For i = Selection.Cells(Selection.Cells.Count).Row _
To Selection.Cells(1).Row Step -1
If Cells(i, "A").Value = IsEmpty(Cells(i, "A").Value) Then Rows(i).EntireRow.Delete = True
Next i
Application.ScreenUpdating = True
If Cells(i, "A").Value = IsEmpty(Cells(i, "A").Value) Then Rows(i).EntireRow.Delete = True

End Sub

Das Problem bei diesem Makro:

Es werden sowohl die "leeren Formelzellen" in der ursprünglichen Tabelle (Tabelle 26) und in der neuen Tabelle (Tabelle 21) gelöscht.

Meine Frage deshalb:
Wie muss ich das o. g. Makro "anpassen", damit nur in der neuen Tabelle (Tabelle 21) die leeren Formelzellen gelöscht werden und die Ursprungstabelle (Tabelle 26) mit den "leeren Formelzellen" erhalten bleibt?

Vielen Dank!

Felix

Answer 1

Hallo Felix,

probier's mal so

Option Explicit

Sub TaballeohneLeerekopieren()
Dim arr(0 To 343, 0), rngC As Range, intZ As Integer
For Each rngC In Worksheets("Tabelle26").Range("A1:A344")
If rngC.Value <> "" Then
arr(intZ, 0) = rngC.Value
intZ = intZ + 1
End If
Next
Worksheets("Tabelle21").Range("A1:A" & intZ) = arr()
End Sub

Gruss
Rainer

Answer 2

Hallo Rainer,

vielen Dank für das Makro!
Es funktioniert so wie ich es mir vorgestellt habe.
Alleine hätte ich das nicht geschafft.
Nun würde ich gerne noch drei Ergänzungen des Makros vornehmen:

- Bevor die Tabelle 26 kopiert wird, sollen die Zellen der Tabelle 21 leer sein (sofern man das Makro vorher schon ausgeführt hat und Änderungen in der Tabelle 26 vorgenommen hat, führt dies dazu, dass weniger Zellen kopiert werden müssen. Das Problem ist dann, dass die "alten" befüllten Zellen stehen bleiben).

- Es sollen auch die Zellenformate der einzelnen Zellen der Tabelle 26 mitkopiert werden.

- Bei Ausführung des Makros soll automatisch die Tabelle 21 ausgewählt werden.

Mein Lösungsvorschlag funktioniert leider nicht. Es wird die Tabelle 21 gelöscht und die Formatierungen der einzelnen Zellen nicht übernommen.
Hier der von Dir übernommene Code mit meinen Änderungen:

Sub TaballeohneLeerekopieren()
ThisWorkbook.Worksheets("Tabelle21").Activate
Range("A1:A340").Clear

Dim arr(0 To 340, 0), rngC As Range, intZ As Integer
For Each rngC In Worksheets("Tabelle26").Range("A1:A340")
If rngC.Value <> "" Then
arr(intZ, 0) = rngC.Value And rngC.FormatConditions

intZ = intZ + 1
End If
Next
Worksheets("Tabelle21").Range("A1:A" & intZ) = arr()
Sheets("Tabelle21").Select
Range("A1").Select
End Sub

Für Lösungsvorschläge wäre ich sehr dankbar!

Gruß
Felix

Answer 3

Hallo Felix,

warum hast Du die Formate nicht gleich erwähnt?

So funktioniert es bei mir.

Option Explicit

Sub TaballeohneLeerekopieren()
Dim rngC As Range
Application.ScreenUpdating = False
For Each rngC In Worksheets("Tabelle26").Range("A1:A340")
If rngC.Value <> "" Then
With Worksheets("Tabelle21").Range("A" & Worksheets("Tabelle21").Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Value = rngC.Value
.Font.ColorIndex = rngC.Font.ColorIndex
.Font.Bold = True = rngC.Font.Bold
.Interior.ColorIndex = rngC.Interior.ColorIndex
'hier kannst Du weitere Formate eintragen
End With
End If
Next
Application.ScreenUpdating = True
End Sub

Gruss
Rainer

Answer 4

Hallo Rainer,

vielen vielen Dank für die schnelle Hilfe!
Leider funktioniert das neue Makro bei mir nicht.
Es erscheint beim Debuggen in der Codezeile:

If rngC.Value <> "" Then

Die Fehlermeldung "Laufzeitfehler 13 Typen unverträglich".
Ich arbeite hier mit Excel 2003.
Könntest Du mir erklären, was ich falsch mache?
Noch einmal vielen Dank!

Gruß

Felix

Answer 5

Hallo Felix,

kann die Fehlermeldung nicht nach vollziehen.
Bei mir läuft der Code sowohl unter Excel 2007 als auch unter Excel 2003.

Lade doch Deine Datei mal hoch.

Gruss
Rainer

Answer 6

Hallo Rainer,

der Fehler lag nicht am Makro sondern in meinen Formeln.
Das Makro funktioniert gut!
Vielen Dank!
Nun hätte ich noch eine letzte Frage:
Bei Ausführung des Makros wird der in der Tabelle 3 (der Beispieldatei) bereits stehende Text immer weiter nach unten verschoben.

Wie kriege ich es hin, dass in der Tabelle 3 nur der Text steht, der bei Ausführung des Makros entsteht?
Also bereits in Tabelle 3 stehender Text soll gelöscht werden.

Ich dachte, dass man am Anfang des Makros schreibt, dass die Spalte A der Tabelle 3 gelöscht wird und dann erst das Makro ausgeführt wird...

Eine Beispieldatei mit der Darstellung des "Problems" habe ich hier hochgeladen:
www.file-upload.net/download-2421277/Zusammenfassung.xls.html

Vielen Dank für die Hilfe und Geduld!

Gruss
Felix

Answer 7

Hallo Felix,

hier die Änderung

Option Explicit

Sub TaballeohneLeerekopieren()
Dim rngC As Range
Application.ScreenUpdating = False
Worksheets("Tabelle3").Range("A:A").Delete
For Each rngC In Worksheets("Tabelle2").Range("A2:A5")
If rngC.Value <> "" Then
With Worksheets("Tabelle3").Range("A" & Worksheets("Tabelle3").Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Value = rngC.Value
.Font.ColorIndex = rngC.Font.ColorIndex
.Font.Bold = True = rngC.Font.Bold
.Interior.ColorIndex = rngC.Interior.ColorIndex
'hier kannst Du weitere Formate eintragen
End With
End If
Next
Sheets("Tabelle3").Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Anstatt
Worksheets("Tabelle3").Range("A:A").Delete
kannst Du auch
Worksheets("Tabelle3").Range("A:A").ClearContents
verwenden, aber dann müsstest Du auch die Formate zurück setzen.
Ich denke aber Delete richtet in diesem Falle keinen Schaden an und ist einfacher.

Gruss
Rainer

Answer 8

Hallo Rainer,

noch einmal vielen Dank für die Hilfe!
Jetzt funktioniert alles so wie es sein soll.

Viele Grüße

Felix

Answer 9

Hi,

nur als Hinweis: mit der Zeile

Worksheets("Tabelle3").Range("A:A").Delete

wird die gesamte Spalte gelöscht , also physisch entfernt. Dieser Effekt spielt zwar hier keine Rolle, ist aber in dem Fall von ausschlaggebender Bedeutung, wenn auch Daten in Spalte B usw. stehen würden, denn das bedeutet, dass alle Spalten rechts von Spalte A nach links nachrücken (ganz einfach zu testen, wenn man mal etwas in Spalte B einträgt).

Zum Leeren von Zellen (Inhalte und Formate) verwendet man besser diesen Code:

Worksheets("Tabelle3").Range("A:A").Clear

denn die Spalte bleibt dabei physisch erhalten.

Bis später,
Karin