Microsoft Excel

Herbers Excel/VBA-Archiv

Bestimmte Zeilen löschen oder markieren


Betrifft: Bestimmte Zeilen löschen oder markieren von: rangy
Geschrieben am: 08.10.2017 20:17:50

Guten Abend.
Hätte gerne für Problem eine Frage. Würde gerne
über VBA bestimmte Zeilen bei Übereinstimmung ganz löschen lassen.
Vorgabe: Exceldatei mit 2 Arbeitsblätter.
Im 1. Arbeitsblatt stehen ca. 6000 Datensätze (immer drei möglich Antworten) wie folgt:
Spalte A Spalte B
1. Name Müller
a. Ja
b. Nein
c. Vielleicht

2. Name Otto
a. Nein
b. Ja
c. ohne Zweifel

3. usw.....

Nun habe ich im 2. Arbeitsblatt folgendes stehen:
Spalte A
1b
2c

Nun sind das im 2. Arbeitsblatt die Lösungen.

Gerne hätte ich es, dass die richtigen Lösungen farblich markiert werden oder
die falschen Lösungen gelöscht werden.

Ich würde mich sehr über eine Antwort freuen.

Gruß
Günter

  

Betrifft: Beispieldatei! o.T. von: Sepp
Geschrieben am: 08.10.2017 20:19:23


Gruß Sepp



  

Betrifft: AW: Beispieldatei! o.T. von: rangy
Geschrieben am: 09.10.2017 05:09:00

Guten Morgen Sepp,
vielen Dank erst mal.

Habe eine Datei hochgeladen wie folgt:
https://www.herber.de/bbs/user/116810.xlsx

Danke und Gruß
rangy


  

Betrifft: AW:mal ein Versuch von: hary
Geschrieben am: 09.10.2017 08:42:01

Moin
Teste mal das Makro.

Sub einfaerben()
Dim Schleife As Long, Zeile As Long
Dim wksQ As Worksheet, wksZ As Worksheet
Dim Bereich As Range
Dim a As Variant
Set wksQ = Worksheets("Tabelle1")
Set wksZ = Worksheets("Tabelle2")
wksQ.Columns(1).Interior.Color = xlNone
  Zeile = 1
    For Schleife = 1 To wksQ.Cells(Rows.Count, 1).End(xlUp).Row Step 5
      Set Bereich = wksQ.Cells(Schleife + 1, 1).Resize(3, 1)
        a = Application.Match(Mid(wksZ.Cells(Zeile, 1), 2, 9 ^ 9) & "*", Bereich, 0)
          If IsNumeric(a) Then
           Bereich.Cells(a).Interior.Color = vbGreen
          End If
      Zeile = Zeile + 1
    Next
Set wksQ = Nothing
Set wksZ = Nothing
Set Bereich = Nothing
End Sub

gruss hary


  

Betrifft: AW: AW:mal ein Versuch von: rangy
Geschrieben am: 09.10.2017 15:04:29

Hallo Hary,

läuft sehr gut, wenn die Lösungen in der richtigen Reihenfolge stehen.
Kann man da was machen, wenn die Lösungen nicht hintereinander stehen?

Gruß


  

Betrifft: noch'n Versuch von: KlausF
Geschrieben am: 09.10.2017 18:36:09

Hallo Hary,
probier mal:

Sub Faerben()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle2")
Dim rng As Range
Dim i As Long, a As Long, r As Long, findRow As Long, x As Long, lngRow As Long
lngRow = wksZiel.Cells(Rows.Count, "A").End(xlUp).Row
Dim strSuche As String, rngSuche As String
a = 1
wksQuelle.Columns(1).Interior.Color = xlNone
Application.ScreenUpdating = False
For i = 1 To wksQuelle.Cells(Rows.Count, "A").End(xlUp).Row Step 5
    With wksZiel
        strSuche = a
        For Each rng In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
            If Left((rng), Len(rng) - 1) = strSuche Then
                findRow = rng.Row
                Exit For
            End If
        Next rng
    End With
    r = Range(Right(wksZiel.Range("A" & findRow), 1) & 1).Column
    Range("A" & i + r).Interior.Color = vbGreen
    a = a + 1
    If a > lngRow Then Exit For
Next
Set wksQuelle = Nothing
Set wksZiel = Nothing
Set rng = Nothing
End Sub
Keine Fehlerkorrektur eingebaut.

Gruß
Klaus


  

Betrifft: noch eine kleine Korrektur von: KlausF
Geschrieben am: 09.10.2017 18:48:34

Sub Faerben()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle2")
Dim rng As Range
Dim i As Long, a As Long, r As Long, findRow As Long, x As Long, lngRow As Long
lngRow = wksZiel.Cells(Rows.Count, "A").End(xlUp).Row
Dim strSuche As String, rngSuche As String
a = 1
wksQuelle.Columns(1).Interior.Color = xlNone
Application.ScreenUpdating = False
For i = 1 To wksQuelle.Cells(Rows.Count, "A").End(xlUp).Row Step 5
    With wksZiel
        strSuche = a
        For Each rng In .Range("A1:A" & lngRow)
            If Left((rng), Len(rng) - 1) = strSuche Then
                findRow = rng.Row
                Exit For
            End If
        Next rng
    End With
    r = Range(Right(wksZiel.Range("A" & findRow), 1) & 1).Column
    Range("A" & i + r).Interior.Color = vbGreen
    a = a + 1
    If a > lngRow Then Exit For
Next
Set wksQuelle = Nothing
Set wksZiel = Nothing
Set rng = Nothing
End Sub
Gruß
Klaus


  

Betrifft: AW: noch eine kleine Korrektur von: rangy
Geschrieben am: 09.10.2017 19:41:21

Hallo Klaus.

Vielen Dank. Ich teste jetzt mal aus.
Melde mich....

Gruß


  

Betrifft: AW: noch eine kleine Korrektur von: rangy
Geschrieben am: 10.10.2017 10:48:32

Guten Tag Klaus,

vielen Dank für Deine tolle Leistung.

Mit etwas Nacharbeit (aber meine Fehler) habe ich
mein Bogen mit Lösung wunderbar bearbeiten können.

Nochmals Danke

Gruß
Günter


  

Betrifft: AW: noch eine kleine Korrektur von: KlausF
Geschrieben am: 10.10.2017 15:04:38

Hallo Günter,
das freut mich! Danke für Deine Rückmeldung.

Gruß
Klaus


Beiträge aus den Excel-Beispielen zum Thema "Bestimmte Zeilen löschen oder markieren"