Tabellen zusammenfügen -VBA

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Tabellen zusammenfügen -VBA

Tabellen zusammenfügen -VBA von Werner Schütz vom 11.10.2014 13:46:26

AW: Tabellen zusammenfügen -VBA - von Raphael H am 11.10.2014 20:12:32
AW: Tabellen zusammenfügen -VBA - von Raphael H am 11.10.2014 20:12:37
- AW: Tabellen zusammenfügen -VBA - von Werner Schütz am 13.10.2014 18:09:08
  - AW: Tabellen zusammenfügen -VBA - von Raphael H am 13.10.2014 21:36:56
    - AW: Tabellen zusammenfügen -VBA - von Werner Schütz am 13.10.2014 23:33:57

Betrifft: Tabellen zusammenfügen -VBA von: Werner Schütz
Geschrieben am: 11.10.2014 13:46:26

Liebe Community,

folgendes Problem plagt mich und ich hoffe auf brauchbare Vorschläge:

Zwei Tabellen zusammenfügen
Vorgaben:
Es handelt sich um zwei Tabellen, die aus einer unbestimmten Zahl von Datensätzen bestehen, sich aber konstant über 25 Spalten erstrecken. Die ersten 3 Zeilen sollen beim Transfer unberücksichtigt bleiben (Kopfzeilen). Die Prozedur soll so ablaufen, dass zunächst die bestehenden Datensätze der 1. Tabelle markiert, dann kopiert und in die Zieltabelle übertragen werden. Danach ist in der Zieltabelle die erste freie Zelle der Spalte A zu markieren, die Datensätze der zweiten Tabelle zu kopieren und im unmittelbaren Anschluss an die bereits übertragenen Datensätze in die Zieltabelle einzufügen.

Dazu habe ich mir aus verschiedenen Vorschlägen von Experten folgenden Makro-Code zusammengebastelt:

Public Sub Petra()
Sheets("Tabelle erste Rechnung").Select
Range(Cells(65536, 1), Cells(Cells(65536, 25).End(xlUp).Row, 25)).Select
Selection.Copy
Sheets("Testtabelle").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim rngBereich As Range, a As Range
Set rngBereich = Range("A4: A65536")
For Each a In rngBereich
If IsEmpty(a) Or a = "" Then
a.Select
Exit For
End If
Next a
Sheets("Tabelle zweite Rechnung").Select
Range(Cells(65536, 1), Cells(Cells(65536, 25).End(xlUp).Row, 25)).Select
Selection.Copy
Sheets("Testtabelle").Select
ActiveSheet.Paste
End Sub

Die Prozedur läuft zunächst einwandfrei ab (Übertragen der Daten der ersten Tabelle, Markieren der ersten freien Zelle, Markieren des Tabellenbereichs in der Zieltabelle, wo die Daten der zweiten Tabelle eingefügt werden sollen ), jedoch findet das Einfügen nicht statt.

Wo kann der Fehler liegen ?

Im Voraus herzlichen Dank für geeignete Vorschläge.

Betrifft: AW: Tabellen zusammenfügen -VBA von: Raphael H
Geschrieben am: 11.10.2014 20:12:32

Hallo Werner,

ich habe keine Ahnung wo dein Fehler liegt....

aber ich denke so sollte es funktionieren

Sub EvtlSo()
    Dim lngZeilen As Long
    Dim RechWs1 As Worksheet
    Dim RechWs2 As Worksheet
    Dim ZielWs As Worksheet
    Dim tempArr1 As Variant
    Dim tempArr2 As Variant
    
    Set RechWs1 = Sheets("Tabelle erste Rechnung")
    Set RechWs2 = Sheets("Tabelle zweite Rechnung")
    Set ZielWs = Sheets("Testtabelle")
    
    'Tabelle n Array schreiben
    With RechWs1
        tempArr1 = .Range(.Cells(4, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 25))
    End With
    
    'Tabelle in Array schreiben
    With RechWs2
        tempArr2 = .Range(.Cells(4, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 25))
    End With
    
    'Ins Zielblatt schreiben
    With ZielWs
        .Cells(4, 1).Resize(UBound(tempArr1, 1), UBound(tempArr1, 2)) = tempArr1
        .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(tempArr2, 1), UBound( _
tempArr2, 2)) = tempArr2
    End With
End Sub

Gruess
Raphael

Betrifft: AW: Tabellen zusammenfügen -VBA von: Raphael H
Geschrieben am: 11.10.2014 20:12:37

Hallo Werner,

ich habe keine Ahnung wo dein Fehler liegt....

aber ich denke so sollte es funktionieren

Sub EvtlSo()
    Dim lngZeilen As Long
    Dim RechWs1 As Worksheet
    Dim RechWs2 As Worksheet
    Dim ZielWs As Worksheet
    Dim tempArr1 As Variant
    Dim tempArr2 As Variant
    
    Set RechWs1 = Sheets("Tabelle erste Rechnung")
    Set RechWs2 = Sheets("Tabelle zweite Rechnung")
    Set ZielWs = Sheets("Testtabelle")
    
    'Tabelle n Array schreiben
    With RechWs1
        tempArr1 = .Range(.Cells(4, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 25))
    End With
    
    'Tabelle in Array schreiben
    With RechWs2
        tempArr2 = .Range(.Cells(4, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 25))
    End With
    
    'Ins Zielblatt schreiben
    With ZielWs
        .Cells(4, 1).Resize(UBound(tempArr1, 1), UBound(tempArr1, 2)) = tempArr1
        .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(tempArr2, 1), UBound( _
tempArr2, 2)) = tempArr2
    End With
End Sub

Gruess
Raphael

Betrifft: AW: Tabellen zusammenfügen -VBA von: Werner Schütz
Geschrieben am: 13.10.2014 18:09:08

Hallo Raphael,

zunächst herzlichen Dank für die schnelle Lösung.

Einen Änderungswunsch habe ich allerdings noch: Wenn die 'Testtabelle' vor Auslösen des Macro nicht leer ist, werden die Daten aus der'Tabelle zweite Rechnung' einfach an den letzten Datensatz der 'Testtabelle' angehängt, das heißt, sie werden (weil sie ja schon einmal vorhanden sind) mehrfach gespeichert. Die Prozedur sollte aber so ablaufen, dass zunächst alle Datensätze aus der 'Testtabelle' entfernt werden und danach die Datensätze so, wie bereits konzipiert, übertragen werden.

Herzliche Grüße

Werner

Betrifft: AW: Tabellen zusammenfügen -VBA von: Raphael H
Geschrieben am: 13.10.2014 21:36:56

Moin,

dann erweitere unten noch um die Zeile mit .Range

    With ZielWs
        .range(.cells(4,1), .cells(.cells(rows.count,1).end(xlup).row,25)).clear
        .Cells(4, 1).Resize(UBound(tempArr1, 1), UBound(tempArr1, 2)) = tempArr1
        .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(tempArr2, 1), UBound(  _
_
tempArr2, 2)) = tempArr2
    End With

Gruess
Raphael

Betrifft: AW: Tabellen zusammenfügen -VBA von: Werner Schütz
Geschrieben am: 13.10.2014 23:33:57

Hallo Raphael,

alles perfekt.

Nochmals herzlichen Dank.

Werner