Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Excel VBA Zellen einfügen ohne überschreiben

Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 14:33:28
Valentina
Hallo zusammen,
ich habe ein kleines Problem mit meinem Excel VBA. Da ich mich leider nicht so gut auskenne, finde ich die Lösung nicht.
Ich habe mehrere Tabellenblätter in einer Datei in der immer mal wieder Zellen rot markiert sind. Jetzt habe ich ein Makro geschrieben, dass er mir aus allen Tabellenblättern die Zeile mit den roten Zellen in ein extra Tabellenblatt namens Übersicht kopiert.
Mein Problem dabei ist, dass er dabei die Zellen immer überschreibt. Das heißt er fügt aus dem ersten Tabellenblatt alle roten Zellen ab A1 ein und für das zweite Tabellenblatt fügt er auch alle Zellen ein aber beginnt dabei wieder bei A1. Wo und welchen Befehl kann ich einfügen, damit er mir guckt ob in der Zeile was steht und das er dann die Zeilen drunter einfügt?
Zum besseren Verständnis füge ich euch meinen Code ein:
Function rot_markieren()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Activate
Dim rngzelle        As Range
Dim lngZeile        As Long
lngZeile = 1
With Worksheets("Übersicht")   'Hier Name des Zielblattes anpassn
For Each rngzelle In ActiveSheet.Range("A1:HH50")   'Suchbereich anpassen
If rngzelle.Interior.ColorIndex = 3 Then
rngzelle.EntireRow.Copy .Cells(lngZeile, 1)
lngZeile = lngZeile + 1
End If
Next rngzelle
End With
Next
End Function
Ich würde mich freuen, wenn mir jemand helfen könnte.
Viele Grüße

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 14:59:27
Nepumuk
Hallo,
teste mal:
Public Sub rot_markieren()
    
    Const OVERVIEW_SHEET As String = "Übersicht"
    Dim sh As Worksheet
    Dim rngzelle As Range
    Dim lngZeile As Long
    Dim strFirstAddress As String
    
    With Application.FindFormat
        Call .Clear
        .Interior.ColorIndex = 3
    End With
    
    For Each sh In ThisWorkbook.Worksheets
        
        If sh.Name <> OVERVIEW_SHEET Then
            
            Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                LookAt:=xlPart, SearchFormat:=True)
            
            If Not rngzelle Is Nothing Then
                
                strFirstAddress = rngzelle.Address
                
                Do
                    
                    lngZeile = lngZeile + 1
                    
                    Call rngzelle.EntireRow.Copy(Destination:= _
                        Worksheets(OVERVIEW_SHEET).Cells(lngZeile, 1))
                    
                    Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                        LookAt:=xlPart, SearchFormat:=True)
                    
                Loop Until rngzelle.Address = strFirstAddress
            End If
        End If
    Next
End Sub

Gruß
Nepumuk

Anzeige
AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 15:09:24
Valentina
danke für den Versuch. Jetzt lässt er die erste Zeile stehen und überschreibt ab A2.

AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 15:16:53
Nepumuk
Hallo,
da war noch ein kleiner Fehler drin.
Public Sub rot_markieren()
    
    Const OVERVIEW_SHEET As String = "Übersicht"
    Dim sh As Worksheet
    Dim rngzelle As Range
    Dim lngZeile As Long
    Dim strFirstAddress As String
    
    With Application.FindFormat
        Call .Clear
        .Interior.ColorIndex = 3
    End With
    
    For Each sh In ThisWorkbook.Worksheets
        
        If sh.Name <> OVERVIEW_SHEET Then
            
            Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                LookAt:=xlPart, SearchFormat:=True)
            
            If Not rngzelle Is Nothing Then
                
                strFirstAddress = rngzelle.Address
                
                Do
                    
                    lngZeile = lngZeile + 1
                    
                    Call rngzelle.EntireRow.Copy(Destination:= _
                        Worksheets(OVERVIEW_SHEET).Cells(lngZeile, 1))
                    
                    Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                        After:=rngzelle, LookAt:=xlPart, SearchFormat:=True)
                    
                Loop Until rngzelle.Address = strFirstAddress
                
                Set rngzelle = Nothing
                
            End If
        End If
    Next
End Sub

Gruß
Nepumuk

Anzeige
AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 15:40:07
Valentina
Hallo Nepumuk,
ich hatte gar nicht gesehen, dass du nochmal geantwortet hast. Tut mir leid!
Super vielen Dank funktioniert jetzt auch!
Viele Grüße

AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 15:17:11
Werner
Hallo Valentina,
erste Frage, warum eine Function und keine normale Sub?
Function rot_markieren()
Dim sh As Worksheet
Dim rngzelle as Range
Dim lngZeile as Long
lngZeile = 1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name  "Übersicht" Then
With Worksheets("Übersicht")   'Hier Name des Zielblattes anpassn
For Each rngzelle In sh.Range("A1:HH50")   'Suchbereich anpassen
If rngzelle.Interior.ColorIndex = 3 Then
rngzelle.EntireRow.Copy .Cells(lngZeile, 1)
lngZeile = lngZeile + 1
End If
Next rngzelle
End With
End If
Next
End Function
Das lngZeile = 1 muss außerhalb des For Each sh .... sein sonst wird beim Wechsel zum nächsten Sheet der Zeilen Zähler wieder auf 1 gesetzt, was zum Überschreiben führt.
Das Activate habe ich auch mal raus genommen. Habe es aber nicht getestet.
Gruß Werner

Anzeige
AW: Excel VBA Zellen einfügen ohne überschreiben
10.05.2016 15:24:07
Valentina
Hallo Werner,
vielen lieben Dank! Das hat funktioniert.
Ich hatte vorher etwas anderes ausprobiert, deswegen stand noch Function und kein Sub. Aber du hast Recht, es müsste natürlich auch mit einem einfachen Sub funktionieren.
Vielen Dank nochmal, du hast meinen Tag gerettet :)
Viele Grüße

AW: Gerne und danke für die Rückmeldung.
10.05.2016 15:36:19
Werner
Hallo Valentina,
Z.K. Nepumuk hat dir auch nochmal geantwortet.
Gruß Werner

330 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige