VBA - C&P ohne Leerzeilen

[Korain]

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!

[NobX]

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

[Kuwer]

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

[Korain]

Perfekt, vielen Dank euch beiden. 

Habt mein Problem einfach gelöst, klasse!

[Gast 123]

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

[snb]

Code:

With ActiveWorkbook.sheets(1).Usedrange
  .autofilter 1 "<>"""
  .offset(1).copy activeworkbook.sheets(2).cells(1)
  .autofilter
End With

[Korain]

Code:

With ActiveWorkbook.sheets(1).Usedrange
  .autofilter 1 "<>"""
  .offset(1).copy activeworkbook.sheets(2).cells(1)
  .autofilter
End With

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

[Korain]

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

[snb]

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

[Korain]

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