VBA Excel: Belegte Zellen in neues Blatt kopieren

[Purple-Haze]

Hallo Zusammen,

folgende Problematik:

Ich habe in einer EXCEL Datei mehrere Tablennblätter, die nach einigen Überschriftenzeilen ab der Zeile 20 Daten in einem konsistenten Format enthalten. Ich möchte nun in einem extra Tabellenblatt alle diese Zeilen aus allen Blättern untereinander kopiert haben:

Also:

Tabelle 1 - Tabelle 20 (Tabellenname immer Tabelle1, Tabelle2 usw)
Jede Tabelle enthält ab Zeile 20 verschiedene Lieferdaten. (Jede Tabelle stellt einen Kunden dar)

In Tabelle 21 möchte ich alle belegten Zeilen ab Zeile 20 aus jeder Kundentabelle für eine Auswertung untereinander kopiert haben:

Aus Tabelle 1 die Zeilen 20-25 in Auswertungstabelle Zeilen 1-5
Aus Tabelle 2 die Zeilen 20-31 in Auswertungstabelle Zeilen 6-17
usw.

Die Tabellen ändern täglich ihre größe, daher ist manuelles kopieren echt zu arbeitsaufwendig.

Ich hatte mir folgendes vorgestellt:

 pos2 = 1
    Set currentcell = Worksheets("Tabelle1").Range("A20")
    Do While Not IsEmpty(currentcell)
        pos2 = pos2 + 1
        Range(Cells(currentcell, 1), Cells(currentcell, 18)).Select
        Selection.Copy
            Worksheets("Status").Select
                Cells(pos2, 1).Select
                ActiveSheet.Paste
            Worksheets("Tabelle1").Select
        Set nextcell = currentcell.Offset(1, 0)
        
        Set currentcell = nextcell
        
    Loop
End Sub

Das ist natürlich nur der Code für eine Kundentabelle. Er müsste dann für jede Tabelle kopiert werden. (Vielleicht kann man das später noch automatisieren).

Das funktioniert aber leider nicht.

Kann mir jemand helfen?

Vielen Dank im Voraus

Purple-Haze

 

[Matthes44]

Hallo,

ich hoffe das bring dich auf den richtigen Weg:

Sub HoleLieferantendaten()
Dim W_I As Long
Dim SchreibeInMappe As String
Dim VonZeile As Long, Biszeile As Long, Inzeile As Long, InSpalte As Long
Dim SchreibeInZeile As Long
SchreibeInMappe = "Tabelle1"
'### Mappe 1 ist immer die Mappe mit den Kundensummen
SchreibeInZeile = 2
For W_I = 2 To ThisWorkbook.Worksheets.Count
'### Die einzelnen Workbooks durchlaufen
VonZeile = 20 ' Starte in dieser Zeile mit dem Einlesen
InSpalte = 1 ' hier sollte eine Spalte eingegeben werden, die immer Werte enthält
Biszeile = ThisWorkbook.Worksheets(W_I).Cells(ThisWorkbook.Worksheets(W_I).Cells.Rows.Count, InSpalte).End(xlUp).Row

For Inzeile = VonZeile To Biszeile
'### Die Zellen von der Lieferantentabelle Zeile für Zeile in die Summentabelle kopieren
SchreibeSpalte = 2
LeseSpalte = 2
ThisWorkbook.Worksheets(SchreibeInMappe).Cells(SchreibeInZeile, SchreibeSpalte) = ThisWorkbook.Worksheets(W_I).Cells(AktZeile, LeseSpalte)
'### Wenn die Spalte Identisch sind ...
ThisWorkbook.Worksheets(SchreibeInMappe).Cells(SchreibeInZeile, SchreibeSpalte + 1) = ThisWorkbook.Worksheets(W_I).Cells(AktZeile, LeseSpalte + 1)
'## Die Zeile in der Summentabelle um eins nach unten verschieben
SchreibeInZeile = SchreibeInZeile + 1
Next Inzeile
Next W_I
End Sub

Tschau

Matthes

Die drei grössten Feinde des Programmierers:
- Sonne
- frische Luft
- und das elende Gebrüll der Vögel

 

[Purple-Haze]

Vielen Dank Matthes,

ich hatte das Problem gestern Nacht noch auf folgende Arrt gelöst:

Option Explicit
Dim c As Integer
Dim pos As Integer
Dim pos2 As Integer
Dim currentcell As Range
Dim nextcell As Range
Dim zelle As Range


Sub auswertung()

' ******************************
' ***** Alte Daten löschen *****
' ******************************

    Sheets("Status").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    
 kunden_kopieren
    
End Sub

Sub kunden_kopieren()
' *****************************************************
' ***** Kunde 1                                   *****
' *****************************************************
 
' kopieren der Überschrift

Sheets("kunde1").Select
    Rows("17:17").Select
    Selection.Copy
    Sheets("Status").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select

' Zählen der belegten Zellen ab 18. und speichern des Wertes in c
   c = 0
    Set currentcell = Worksheets("kunde1").Range("A18")
    Do While Not IsEmpty(currentcell)
        Set nextcell = currentcell.Offset(1, 0)
            c = c + 1: Debug.Print c
        Set currentcell = nextcell
    Loop

' Copy / paste

pos = 17
pos2 = 0
Sheets("kunde1").Select
For Each zelle In Range(Cells(18, 1), Cells(c + 17, 1))

pos = pos + 1
    If zelle.Value <> "" Then

    pos2 = pos2 + 1
    Range(Cells(pos, 1), Cells(pos, 71)).Copy
    Worksheets("status").Select
    Cells(1 + pos2, 1).Select
    ActiveSheet.Paste
    Worksheets("kunde1").Select

End If
Next zelle

Diese Lösung muss natürlich für jedes Blatt einzelnd erstellt werden und ist daher nicht sehr praktikabel. Aber ich werde mir Deinen Vorschlag in Ruhe anschauen und vielleicht eine Kombination aus beidem machen.

Schönes Wochenende noch.

Purple-Haze