Clever-Excel-Forum - VBA - C&P ohne Leerzeilen

Seiten: 1 2

Hallo zusammen,

ich möchte aus einer anderen Datei nur Werte kopieren und in einer anderen Datei einfügen.
Wobei ich Hilfe benötige:
Sollen nur Zeilen kopiert werden in denen Werte sind. Z.b: habe ich aktuell einen fixen Bereich angegeben, aber zwischen werten und nach Werten können Leerzeilen sein, die nicht übernommen werden sollen.

Ob eine Zeile leer ist oder nicht soll abgefragt werden, ob in Spalte D ein Wert steht.

Code:
    'Bereich in dem die Werte stehen

    ActiveWorkbook.Worksheets(TabellenName).Range("A7:AV50000").Select

    'In den Zwischenspeicher einlesen

    Selection.Copy

    'Workbookwechseln

    Workbooks(NameWork).Activate

    'erste freie Zeile ermitteln

    Call lastrowRechnung

    Hilfsrechner = lastrow + 1

    'erste freie Zeile auswählen

    ws.Cells(Hilfsrechner, 1).Select

    'Ausschließlich Werte der kopierten Daten einfügen

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=True, Transpose:=False

Vielen Dank!

Hallo Korain,

die Verarbeitung Deiner Abfrage sollte über eine Schleife laufen. - Ich habe Dir ein getestetes Beispiel ausgearbeitet. Du musst noch die Namen der Workbooks und der Tabellenblätter entsprechend hinzufügen bzw. anpassen:

Code:
Sub Werte_uebertragen_N()

Dim firstRow As Integer

Dim lastRow As Long

Dim i As Long

Dim firstIn As Long

firstRow = 1 'erste zu prüfende Zeile bitte anpassen

lastRow = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile in der Quelldatei - Blattnamen anpassen

firstIn = Tabelle2.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 'Ermittlung erster freier Zeile auf dem Zielblatt (Name Datei fehlt noch)

    With Tabelle1

        For i = firstRow To lastRow

            If .Cells(i, 4) <> "" Then 'Falls Werte in Tabelle1 Zelle "D4" stehen ....

            .Range(.Cells(i, 1), .Cells(i, 48)).Copy

            Sheets("Tabelle2").Cells(firstIn, 1).PasteSpecial Paste:=xlPasteValues 'hier muss noch das Workbook angeben werden

            firstIn = firstIn + 1

            End If

        Application.CutCopyMode = False

        Next

    End With

End Sub

Es gibt hier sicherlich noch viele weitere Möglichkeiten, vor allem in der Beschleunigung der Ausführung bei extrem großen Datenmengen, - z. B. durch die Verarbeitung im Arbeitsspeicher (Array). Teste es einfach einmal ob es für Dich funktioniert, sonst stellst Du Deine Testdatei einfach noch einmal ins Forum und präzisierst Dein Anliegen dazu noch einmal.

Grüße
Norbert

Hallo Korain,

Code:
    'Bereich in dem die Werte stehen, in den Zwischenspeicher einlesen

    With ActiveWorkbook.Worksheets(TabellenName).Range("A7:AV50000")

      If Application.WorksheetFunction.CountA(.Columns(4)) = 0 Then Exit Sub

      Application.Intersect(.Columns(4).SpecialCells(xlCellTypeConstants).EntireRow, .Columns).Copy

    End With

Gruß Uwe

Perfekt, vielen Dank euch beiden.

Habt mein Problem einfach gelöst, klasse!

Hallo

@Uwe alle Achtung, Hut ab, schmunzel, schmunzel! Das ist eindeutig die beste Lösung die ich sehe. Über Special Cells, die tolle Idee kam mir nicht!!

Es über eine Schleife zu machen habe ich bei 50.000 Zeilen direkt verworfen, da kann man getrost ins Kino gehen bis der PC fertig ist!
Meine Lösung wäre über Kopieren mit anschliessendem Sortieren und Leerzeilen löschen gewesen. Eine alte Methode, aber auch effektiv.
Die einfachste und beste Lösung ist aber ganz klar von Uwe. Gratuliere dir zu dieser tollen Idee.

mfg Gast 123

Code:
Sub OhneLeerzellen_kopieren()

Dim lastrowRechnung As Long

Dim lastrowDaten As Long

Dim lastrowSort As Long

Dim SAdr, SEnd, Adr1, Adr2

Dim Zws As Worksheet, n  As Long

    Application.ScreenUpdating = False

    'Workbook in Set laden

    Set Zws = Workbooks(NameWork).Worksheets(Zieltabelle)

    'erste freie Zeile in ext. Tabelle ermitteln

    lastrowRechnung = Zws.Cells(Rows.Count, 1).End(xlUp).Row + 1

    'Bereich in dem die Werte stehen kopieren

With ActiveWorkbook.Worksheets(TabellenName)

     lastrowDaten = .Cells(Rows.Count, 1).End(xlUp).Row + 1

     .Range("A7:AV" & lastrowDaten).Copy  'Datenbereich kopieren

     'Daten in Ziieltabelle Spalte B einfügen

      Zws.Cells(lastrowRechnung, 2).PasteSpecial Paste:=xlPasteValues, _

          Operation:=xlNone, SkipBlanks:=True, Transpose:=False

End With

With Zws

     'Datensatz Sortieren vorbereiten

     lastrowSort = .Cells(Rows.Count, 2).End(xlUp).Row

     SAdr = Zws.Cells(lastrowRechnung, 1).Address   'Spalte A

     Adr1 = Zws.Cells(lastrowRechnung, 5).Address   'Spalte D  (jetzt E)

     Adr2 = Zws.Cells(lastrowRechnung, 2).Address   'Spalte B

     SEnd = "AW" & lastrowSort  'Sort Bereich End Adresse

     'Spalte A Lauf Nr. von 1 bis xxx ausfüllen

     .Range(SAdr).Value = 1: n = lastrowSort - lastrowRechnung + 1

     .Range(SAdr).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=n

     'Datensatz nach Spalte D (jetzt E) und Lauf nr sortieren

     .Range(SAdr, SEnd).Sort Key1:=.Range(Adr1), _

      Order1:=xlAscending, Key2:=.Range(Adr2), _

      Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, _

      MatchCase:=True, Orientation:=xlTopToBottom

     'Spalte A und Zeilen nach lastrowSort löschen

     .Cells(lastrowRechnung, 1).Resize(lastrowSort, 1).Delete Shift:=xlToLeft

     'neue LastRow Zeile ermitteln  (ohne Leerzeilen)

     lastrowSort = .Cells(Rows.Count, 2).End(xlUp).Row + 1

     .Rows(lastrowSort & ":" & Rows.Count).Delete Shift:=xlUp

End With

End Sub

Code:
With ActiveWorkbook.sheets(1).Usedrange

  .autofilter 1 "<>"""

  .offset(1).copy activeworkbook.sheets(2).cells(1)

  .autofilter

End With

(28.01.2022, 18:53)snb schrieb: [ -> ]
Code:
With ActiveWorkbook.sheets(1).Usedrange .autofilter 1 "<>""" .offset(1).copy activeworkbook.sheets(2).cells(1) .autofilter End With

(28.01.2022, 11:30)Kuwer schrieb: [ -> ]Hallo Korain,

Code:
'Bereich in dem die Werte stehen, in den Zwischenspeicher einlesen With ActiveWorkbook.Worksheets(TabellenName).Range("A7:AV50000") If Application.WorksheetFunction.CountA(.Columns(4)) = 0 Then Exit Sub Application.Intersect(.Columns(4).SpecialCells(xlCellTypeConstants).EntireRow, .Columns).Copy End With

Gruß Uwe

Hallo Ihr beiden,

gibt es zusätzlich noch eine Möglichkeit bestimmt Spalten, wie Spalte F auszuschließen?
Heißt dass nur die Spalten A-E und G-Z importiert werden? Leider musste ich die Datei verändern und ich Spalte F ist eine Formel hinterlegt, welche nicht überschrieben werden sollte.

Beste Grüße
Korain

Habe es jetzt so gelöst, dass ich einfach die Formeln von oben jeweils neu runter ziehe.

z.B. ohne Spalte F

Code:
With ActiveWorkbook.sheets(1).Usedrange

  .autofilter 1 ,"<>"""

  .offset(1).resize(,5).copy activeworkbook.sheets(2).cells(1)

  .offset(1,5).copy activeworkbook.sheets(2).cells(1,6)

  .autofilter

End With

(31.01.2022, 12:23)snb schrieb: [ -> ]z.B. ohne Spalte F

Code:
With ActiveWorkbook.sheets(1).Usedrange .autofilter 1 "<>""" .offset(1).resize(,5).copy activeworkbook.sheets(2).cells(1) .offset(1,5).copy activeworkbook.sheets(2).cells(1,6) .autofilter End With

Hallo danke dir für deine Antwort.

er zeigt bei mir jedoch bei .autofilter 1 "<>""" einen Fehler an.

Fehler beim Kompilieren:
Erwartet: Anweisungsende

Seiten: 1 2