Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1696to1700
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Überprüfung, ob Zelle leer ist

Überprüfung, ob Zelle leer ist
19.06.2019 13:33:14
MaAs
Hallo Zusammen,
ich habe folgendes Problem:
In meiner ursprünglichen Tabelle sind nur die Spalten A bis J beschriftet, wobei Spalte C Namen enthält. Die Namen können einmal, zweimal oder dreimal untereinander erscheinen.
Ich lasse nun untersuchen, ob die Namen in Spalte C mehrfach vorkommen. Wenn ja, dann werden die Eigenschaften aus Spalten 6 bis 10 kopiert und in den Spalten 11 bis 15 eingefügt. Das klappt klappt auch soweit. Wenn aber der Name ein drittes Mal auftaucht, sollen die Eigenschaften in Spalte 16 eingefügt werden, da ja die Spalten 11 bis 15 bereits belegt sind. Das funktioniert aber nicht, statt dessen werden die Spalten 11 bis 15 überschrieben. Ich hoffe, ich konnte mein Anliegen einigermaßen anschaulich schildern. Hier das Makro:
Sub Mehrfachkurse()
Dim i As Integer
For i = 2 To 500
If IsEmpty(Cells(i, 3).Value) = True Then
Exit Sub
Else
Do While Cells(i, 3).Value = Cells(i + 1, 3).Value
Range(Cells(i + 1, 6), Cells(i + 1, 10)).Select
Selection.Copy
If IsEmpty(Tabelle1.Cells(i, 11).Value) = True Then
Cells(i, 11).PasteSpecial Paste:=xlPasteValues
Else
Cells(i, 16).PasteSpecial Paste:=xlPasteValues
Cells(i + 1, 6).EntireRow.Delete
End If
Loop
End If
Next
End Sub
Vielen Dank
Mariam


		

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

Betreff
Datum
Anwender
Anzeige
AW: Überprüfung, ob Zelle leer ist
19.06.2019 14:15:43
UweD
Hallo
so?
Sub Mehrfachkurse()

    Dim LR As Integer, i As Integer
                   
    LR = Cells(Rows.Count, "C").End(xlUp).Row 'letzte Zeile der Spalte 
    For i = 2 To LR
        If IsEmpty(Cells(i, 3).Value) = True Then
    
            Exit Sub
        Else
             
            Do While Cells(i, 3).Value = Cells(i + 1, 3).Value
             
                Range(Cells(i + 1, 6), Cells(i + 1, 10)).Copy
                 
                If IsEmpty(Tabelle1.Cells(i, 11).Value) = True Then
                 
                    Cells(i, 11).PasteSpecial Paste:=xlPasteValues
                    Cells(i + 1, 6).EntireRow.Delete
                 
                Else
                                        
                    Cells(i, 16).PasteSpecial Paste:=xlPasteValues
                    Cells(i + 1, 6).EntireRow.Delete
                 
                End If
                       
            Loop
        
        End If
    Next
                

End Sub
LG UweD
Anzeige
AW: Überprüfung, ob Zelle leer ist
19.06.2019 14:59:08
MaAs
Hi,
Danke für die Antwort. Aber da passiert leider genau das selbe wie bei mir. Bei Namen, die doppelt vorkommen, klappt es problemlos. Wenn jetzt Namen dreimal vorkommen passiert folgendes:
Beispiel
Hans Kurs A
Hans Kurs B
Peter Kurs A
Peter Kurs B
Peter Kurs C
Ich möchte folgendes:
Hans Kurs A Kurs B
Peter Kurs A Kurs B Kurs C
Das Makro macht aber:
Hans Kurs A Kurs B
Peter Kurs A Kurs C
Das ist gerade etwas abstrakt beschrieben. Hoffe es ist verständlich.
Liebe Grüße
Mariam
AW: Überprüfung, ob Zelle leer ist
19.06.2019 15:11:52
UweD
Hallo
Also bei mir macht das makro genau das.
Aus

Orig
 ABCDEF
1  Ü   
2  Hans  Kurs A
3  Hans  Kurs B
4  Peter  Kurs A
5  Peter  Kurs B
6  Peter  Kurs C
7      
http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip
http://Hajo-Excel.de/tools.htm
XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007
Add-In-Version 25.14 einschl. 64 Bit


wird

Tabelle1
 ABCDEFGHIJKLMNOPQ
1  Ü              
2  Hans  Kurs A    Kurs B      
3  Peter  Kurs A    Kurs B    Kurs C 
4                 
5                 
6                 
http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip
http://Hajo-Excel.de/tools.htm
XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007
Add-In-Version 25.14 einschl. 64 Bit


LG UweD
Anzeige
AW: Überprüfung, ob Zelle leer ist
19.06.2019 15:34:18
MaAs
Hi
Ich habe jetzt mal eine fiktive Datei erstellt, da klappt es. Aber in meiner richtigen Datei funktioniert das einfach nicht. Ich bin am verzweifeln. Da ist bestimmt ein winziger Fehler, den ich einfach nicht sehe.
LG Mariam
dann lad doch mal..
19.06.2019 15:52:21
UweD
...eine Datei mit Originaldaten hoch
LG UweD
AW: dann lad doch mal..
19.06.2019 16:19:12
UweD
Hallo
Fehler hier...
If IsEmpty(Tabelle1.Cells(i, 11).Value) = True Then
besser so
Modul1
Sub Mehrfachkurse() 
    Dim LR As Integer, i As Integer 
 
    '***Sheets("Teilnehmerliste Summer School").Select 
    Sheets("Teilnehmerliste Summer School").Copy Before:=Sheets(1) 
    '***Sheets("Teilnehmerliste Summer Scho (2)").Select 
    ActiveSheet.Name = "Druckversion" 
 
                   
    '***Cells.Select 
    ' Nach Namen sortieren, bevor Programm startet 
    ActiveWorkbook.Worksheets("Druckversion").Sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("Druckversion").Sort.SortFields. _
        Add2 Key:=Range("C2:C1000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal 
     
    With ActiveWorkbook.Worksheets("Druckversion").Sort 
        .SetRange Range("A1:W1000") 
        .Header = xlYes 
        .MatchCase = False 
        .Orientation = xlTopToBottom 
        .SortMethod = xlPinYin 
        .Apply 
    End With 
                      
 
 
     
    With ActiveWorkbook.Worksheets("Druckversion") 
                   
        LR = .Cells(.Rows.Count, "C").End(xlUp).Row 'letzte Zeile der Spalte 
        For i = 2 To LR 
            If IsEmpty(.Cells(i, 3).Value) = True Then 
         
                Exit Sub 
            Else 
                  
                Do While .Cells(i, 3).Value = .Cells(i + 1, 3).Value 
                  
                    .Range(.Cells(i + 1, 6), .Cells(i + 1, 10)).Copy 
                      
                    If IsEmpty(.Cells(i, 11).Value) = True Then 
                      
                        .Cells(i, 11).PasteSpecial Paste:=xlPasteValues 
                        .Cells(i + 1, 6).EntireRow.Delete 
                      
                    Else 
                                             
                        .Cells(i, 16).PasteSpecial Paste:=xlPasteValues 
                        .Cells(i + 1, 6).EntireRow.Delete 
                      
                    End If 
                            
                Loop 
             
            End If 
        Next 
    End With 
 
End Sub 

LG UweD
Anzeige
Erklärung..
19.06.2019 16:25:03
UweD
hatte ich noch vergessen
"Tabelle1 " dadurch wurde auf der falschen Tabelle nachgesehen
Die '*** Zeilen brauchst du nicht
LG UweD
AW: dann lad doch mal..
19.06.2019 16:28:44
MaAs
Vielen vielen Dank, dass du die Zeit investiert hast.
Danke auch für die Schönheitskorrekturen. Ich bau halt alles auf Aufzeichnungen auf, weil ich nie Programmieren gelernt habe.
LG Mariam
Danke für die Rückmeldung owT
19.06.2019 16:39:02
UweD
AW: Überprüfung, ob Zelle leer ist
19.06.2019 15:06:34
Beverly
Hi Mariam,
vielleicht so:
Sub Zusammenfassen()
Dim lngZeile As Long
Dim rngZelle As Range
Dim intSpalte As Integer
Dim strStart As String
Dim lngLetzte As Long
lngLetzte = Cells(Rows.Count, "A").End(xlUp).Row
For lngZeile = 2 To lngLetzte
Set rngZelle = Columns(3).Find(Cells(lngZeile, 3), lookat:=xlWhole)
If Not rngZelle Is Nothing Then
strStart = rngZelle.Address
Do
intSpalte = IIf(IsEmpty(Cells(lngZeile, Columns.Count)), _
Cells(lngZeile, Columns.Count).End(xlToLeft).Column, Columns.Count) + 1
If rngZelle.Address  strStart Then
If rngZelle.Offset(0, -2) = "" Then Exit Do
Range(rngZelle.Offset(0, 3), rngZelle.Offset(0, 7)).Copy
Cells(lngZeile, intSpalte).PasteSpecial Paste:=xlValues
rngZelle.Interior.ColorIndex = 3
rngZelle.Offset(0, -2).ClearContents
End If
Set rngZelle = Columns(3).FindNext(rngZelle)
Loop While rngZelle.Address  strStart
End If
Next lngZeile
Range(Cells(1, 1), Cells(lngLetzte, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub


Anzeige
AW: Überprüfung, ob Zelle leer ist
19.06.2019 15:35:35
MaAs
Hi,
danke für die Antwort. Aber meine Daten verschwinden alle. Da passiert sonst nichts.
LG Mariam
AW: Überprüfung, ob Zelle leer ist
19.06.2019 16:04:43
Beverly
Hi Mariam,
das kann ich in meiner Mappe nicht nachvollziehen - sie geht aber davon aus, dass Spalte A komplett gefüllt ist mit Daten und keine Leerzellen vorkommen.
Im angehängten Beispiel habe ich mal das Löschen der Zeilen auskommentiert und nur den Inhalt der Spalte A geleert (das ist Grundlage für das Funktionieren des Codes) und stattdessen die mehrfach vorkommenden Werte in Spalte C mit Füllfarbe Rot formatiert.
https://www.herber.de/bbs/user/130492.xlsm


Anzeige
Ausgehend von deiner hochgeladenen Mappe...
19.06.2019 16:29:13
deiner
Hi Mariam,
die anders aufgebaut ist als ich für meinen Code angenommen hatte, hier mein Vorschlag:
Sub Zusammenfassen()
Dim lngZeile As Long
Dim rngZelle As Range
Dim intSpalte As Integer
Dim strStart As String
lngLetzte = Cells(Rows.Count, "C").End(xlUp).Row
For lngZeile = 2 To lngLetzte
Set rngZelle = Columns(3).Find(Cells(lngZeile, 3), lookat:=xlWhole)
If Not rngZelle Is Nothing Then
strStart = rngZelle.Address
intSpalte = 11
Do
If rngZelle.Address  strStart Then
If rngZelle.Offset(0, 1) = "" Then Exit Do
Range(rngZelle.Offset(0, 3), rngZelle.Offset(0, 7)).Copy
Cells(lngZeile, intSpalte).PasteSpecial Paste:=xlValues
rngZelle.Offset(0, 1).ClearContents
intSpalte = intSpalte + 5
End If
Set rngZelle = Columns(3).FindNext(rngZelle)
Loop While rngZelle.Address  strStart
End If
Next lngZeile
Range(Cells(1, 4), Cells(lngLetzte, 4)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub


Anzeige
AW: Ausgehend von deiner hochgeladenen Mappe...
19.06.2019 16:53:32
deiner
Hi Beverly,
ja das klappt auch super. Ich war vorhin wohl zu nervös, um das Makro auf meine Mappe umzuschreiben.
Danke auch für deine Zeit. Es ist interessant, auf wie viele unterschiedliche Wege man ein Problem lösen kann.
LG
Mariam
Danke für die Rückmeldung - o.w.T.
19.06.2019 16:55:03
Beverly


305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige