Lösung wiederholend End(xlDown)" um leere Zelle zu Übergehen

Moderator: ModerationP

Lösung wiederholend End(xlDown)" um leere Zelle zu Übergehen

Beitragvon Twiti » 07. Sep 2021, 07:12

Hallo Experten-Forum,

Ich füge mit folgendem Code Daten in einer zweiten Tabelle ein.

Code: Alles auswählen
With Worksheets("IIR").Range("A1:AH1")
m = ActiveCell.Value
        Set C = .Rows(1).Find(what:=m, LookIn:=xlValues, lookat:=xlWhole)
        If Not C Is Nothing Then
   
firstAddress = C.Address
Worksheets("IIR").Activate
Range(firstAddress).Activate
Range(Selection.Offset(1, 0), Selection.End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown)).Select
Selection.Copy
Worksheets("RRI").Activate
ActiveCell.Offset(1, 0).PasteSpecial
cutcopy = False
Else
        End If
End With


Weil es mehrere leere Zellen gibt habe ich raus gefunden dass mit dem wiederholenden "End(xlDown)"
das Problem gelöst ist. Die Wiederholung ist aber beschränkt auf der maximale Zeilenlänge im Code-Editor.
Code: Alles auswählen
Range(Selection.Offset(1, 0), Selection.End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown)).Select

Gibt es eine andere Lösung wobei es unendlich die leere Zellen überspringt?

Ich freue mich auf euren Ideen.
Twiti
Windows 10/Office 2019 Professional Plus
Dragon NaturallySpeaking statt Maus und Tastatur wegen Schwerbehinderung
Twiti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 265
Registriert: 23. Apr 2016, 13:53

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Der Steuerfuzzi » 07. Sep 2021, 07:28

Hallo,

was willst Du eigentlich genau machen? Daten am Ende der Tabelle einfügen? Dann sollte man das Ende der Tabelle von ganz unten aus mit xlup ermitteln und nicht mit xldown.
Viele Grüße
Michael
Benutzeravatar
Der Steuerfuzzi
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 3918
Registriert: 25. Mär 2013, 13:28

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Lutz Fricke » 07. Sep 2021, 11:04

Hallo Twiti,

schau doch mal da:
https://www.excel-inside.de/vba-loesung ... -ermitteln

Gruß,
Lutz
Lutz Fricke
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 393
Registriert: 27. Mär 2017, 12:12

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Twiti » 09. Sep 2021, 06:41

Danke Lutz, danke Michael für euren Antworten.

Ich will die Daten aus Worksheet IIR unter den gleichen Spaltenkopf im sheet RRI kopieren.
Die Spaltensortierung in sheet RRI ist variabel, deshalb dieser Weg.

Egal ob xlDown oder xlUp kopiert wird immer nur bis zum 1. leere Zelle in dieser Spalte, um zum nächsten zu springen
wiederhole ich das End(xlDown) mehrfach (bis zum maximalen Länge der Zeile).

Ich suche nach einer anderen funktionierenden Lösung, kennt ihr den Weg?

Viele Grüße aus der Isarwinkl
Twiti
Windows 10/Office 2019 Professional Plus
Dragon NaturallySpeaking statt Maus und Tastatur wegen Schwerbehinderung
Twiti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 265
Registriert: 23. Apr 2016, 13:53

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Der Steuerfuzzi » 09. Sep 2021, 07:31

Hi Twiti,

lade doch mal eine Beispieldatei hier hoch. Ich glaube nicht, dass bei xlup zur ersten freien Zelle von oben gesprungen wird. Es müsste eigentlich(richtig angewendet) zur letzten befüllten zelle von unten springen.
Viele Grüße
Michael
Benutzeravatar
Der Steuerfuzzi
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 3918
Registriert: 25. Mär 2013, 13:28

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Lutz Fricke » 09. Sep 2021, 09:05

Hallo Twiti,

mit
Code: Alles auswählen
letztezeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
solltest Du von der letzten Zeile des Blattes ausgehend die von unten erste beschrieben Zeile in Spalte A bekommen.
Cells(Rows.Count, 1) ist die letzte Zeile in Spalte A und dann mit End(xlUp) nach oben.

Aber das steht ja auch im Link...

Gruß,
Lutz
Lutz Fricke
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 393
Registriert: 27. Mär 2017, 12:12

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Twiti » 24. Sep 2021, 10:00

Hallo Lutz,
ich habe versucht deinem Tipp umzusetzen.

Es will nicht funktionieren wie ich mir wünsche.
Ich hänge in folgende Zeile:
Code: Alles auswählen
Range(Selection.Offset(1, 0), Cells(letzteZeile, X)).Select

wie kann ich diese X anhand der vorhergegangenen Code festlegen?

Hier der gesamte Prozedur:
Code: Alles auswählen
Sub Z()
Worksheets("IIR Report").Activate
letzteZeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

'On Error GoTo schluss
Worksheets("Reformatted").Activate
LR = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
sp = Cells(1, Columns.Count).End(xlToLeft).Column
'

Range("G1").Activate

For i = 1 To sp - 6 '.usedrangeColumns.Count

With Worksheets("IIR Report").Range("A1:AH1")
m = ActiveCell.Value
'Set c = .Find(m, LookIn:=xlValues)
        Set C = .Rows(1).Find(what:=m, LookIn:=xlValues, lookat:=xlWhole)
        If Not C Is Nothing Then
'    If c Is Nothing Then GoTo schluss
   
firstAddress = C.Address
Worksheets("IIR Report").Activate
Range(firstAddress).Activate
Range(Selection.Offset(1, 0), Cells(letzteZeile, i + 3)).Select
'Range(Selection.Offset(1, 0), Selection.End(xlUp)).Select

'Range(Selection.Offset(1, 0), Selection.End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown)).Select
Selection.Copy
Worksheets("Reformatted").Activate
ActiveCell.Offset(1, 0).PasteSpecial
cutcopy = False
Else
        End If
End With

schluss:
'Worksheets("Reformatted").Select 'Activate
ActiveCell.Offset(-1, 1).Activate
Next i
End Sub


Ich komm nicht weiter,
im Voraus schon mal danke für deine Hilfe.
Twiti
Windows 10/Office 2019 Professional Plus
Dragon NaturallySpeaking statt Maus und Tastatur wegen Schwerbehinderung
Twiti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 265
Registriert: 23. Apr 2016, 13:53

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon HKindler » 24. Sep 2021, 10:51

Hi,

verzichte auf die Select- und Activate-Orgien. Das ist doch nur unübersichtlich und aufwändig. Siehe dazu https://www.online-excel.de/excel/singsel_vba.php?f=78

Ausgehend von deinem ersten Code erhält man mit dem Hinweis von Lutz:
Code: Alles auswählen
With Worksheets("IIR").Range("A1:AH1")
m = ActiveCell.Value
        Set C = .Rows(1).Find(what:=m, LookIn:=xlValues, lookat:=xlWhole)
        If Not C Is Nothing Then
   
firstAddress = C.Address
Worksheets("IIR").Activate
Range(firstAddress).Activate
Cells(Rows.Count, ActiveCell.Column).End(xlUp)
Selection.Copy
Worksheets("RRI").Activate
ActiveCell.Offset(1, 0).PasteSpecial
cutcopy = False
Else
        End If
End With

Wenn man es vernünftig programmiert, dann bekommt man eher so etwas:
Code: Alles auswählen
With Worksheets("IIR")
    Set C = .Range("A1:AH1").Find(what:=ActiveCell.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not C Is Nothing Then
        ActiveCell.Offset(1, 0) = .Cells(Rows.Count, C.Column).End(xlUp)
    End If
End With
Gruß,
Helmut

----------------------------
Windows 10 Enterprise (64 Bit) / Office 365 ProPlus (32 Bit)
Benutzeravatar
HKindler
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 6294
Registriert: 04. Jul 2013, 09:02
Wohnort: Schwarzwald

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon 1Matthias » 24. Sep 2021, 12:19

Moin!
Hier mal mein Beitrag zu dem Thema. Wenn ich das richtig deute, willst du ab Spalte G1 (also der Wert in Zeile 1 = Spaltenname) bis zum Ende der gefüllten Spalten, den Spaltennamen aus dem Blatt Reformated im Blatt IIR Report suchen. Wenn er dort gefunden wurde, willst du dann alle Zeilen der gefundenen Spalte nach Reformated in die entsprechende Spalte kopieren. Da die Überschrift ja auch gleich ist und du die Daten nicht unten anfügst, sondern überschreibst, könntest du auch die ganze Spalte kopieren. Hier aber der Code, wie er ab Zeile 2 alles kopiert. Um nicht immer die Blattnamen zu schreiben, weise ich die am Anfang kürzeren Variablen (Quelle und Ziel) zu.

Code: Alles auswählen
Sub kopieren_twiti()
Dim suchspalte
Dim treffer
Dim quelle As Worksheet, ziel As Worksheet
Dim letzteZeile As Long, spalten As Long

'von hier wird kopiert
Set quelle = Worksheets("IIR Report")

'nach hier wird kopiert
Set ziel = Worksheets("Reformatted")
'Anzahl der belegten Spalten
spalten = ziel.Cells(1, ziel.Columns.Count).End(xlToLeft).Column

'7 entspricht Spalte G, bis zum Ende, Spalte ist dabei die Spaltennummer
For spalte = 7 To spalten

    'Wert Zeile 1 der Spalte im Blatt Reformatted
    suchspalte = ziel.Cells(1, spalte).Value
    'prüfen, dass die Spalte nicht leer ist
    If suchspalte <> "" Then
        'den Wert im Blatt jetzt im Blatt IIR suchen, treffer wird dabei der Treffer
        Set treffer = quelle.Rows(1).Find(what:=suchspalte, LookIn:=xlValues, lookat:=xlWhole)
        If Not treffer Is Nothing Then
            'Spalte wurde gefunden, jetzt den gesamten Inhalt kopieren und unter die Überschrift kopieren
            'da die Überschrift gleich ist, könnte man natürlich auch die ganze Spalte kopieren
            'die Spaltennummer bekommt man über treffer.column
           
            letzteZeile = quelle.Cells(quelle.Rows.Count, treffer.Column).End(xlUp).Row
            'kopiert wird in die Spalten
            quelle.Cells(2, treffer.Column).Resize(letzteZeile - 1).Copy ziel.Cells(2, spalte)
        End If
    End If
Next

End Sub
]

VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 963
Registriert: 15. Aug 2017, 18:36

Re: Lösung wiederholend End(xlDown)" um leere Zelle zu Überg

Beitragvon Twiti » 28. Sep 2021, 10:13

@Helmut und @Matthias
danke für die gute Hilfe, jetzt läuft's.
Viele Grüße
Tom
Twiti
Windows 10/Office 2019 Professional Plus
Dragon NaturallySpeaking statt Maus und Tastatur wegen Schwerbehinderung
Twiti
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 265
Registriert: 23. Apr 2016, 13:53


Zurück zu Excel Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 13 Gäste