Tabellen zusammenführen
15.05.2016 18:49:49
Matze
anbei mein Code (mit Hilfe von "Luschi"), wo die Tabellen 2,4 und 5 in Tabelle 6 zusammengefasst werden.
Wie muss ich den Code ergänzen, damit er immer die alten Inhalte aus Tabelle6 löscht und dann neu befüllt - also, dass die Daten immer aktuell sind. Momentan schreibt er mir die Zusammenfassungen in Tabelle6 immer untereinander, sobald man die Schaltfläche erneut drückt bzw. das Makro auslöst.
Sub Zusammenschreiben()
Dim ws As Worksheet
Dim wsTotal As Worksheet
Dim lngLastCol As Long
Dim lngLastRow As Long
Dim rngTotalFound As Range
Dim lngTotalRow As Long
Dim lngCounter As Long
Dim strSearch As String
Dim sTabs As String
'Tabellen, die zusammengeführt werden sollen
sTabs = "*Tabelle2*Tabelle4*Tabelle5*"
On Error GoTo Zusammenschreiben_Error
Application.ScreenUpdating = False
Set wsTotal = Sheets("Tabelle6")
For Each ws In Worksheets
If InStr(1, sTabs, "*" & ws.Name & "*", vbTextCompare) > 0 _
Then
lngTotalRow = wsTotal.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print lngTotalRow
With ws
lngLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A2:A" & lngLastRow).Copy Destination:=wsTotal.Range("A" & lngTotalRow) 'Spalte A _
kommt in Spalte A
.Range("B2:F10" & lngLastRow).Copy Destination:=wsTotal.Range("G" & lngTotalRow) 'Spalten _
B bis F kommen in Spalte G bis K
If lngLastCol > 6 Then
For lngCounter = 7 To lngLastCol
strSearch = ws.Cells(1, lngCounter)
Set rngTotalFound = wsTotal.Rows("1:1").Find( _
what:=strSearch, LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByRows)
If rngTotalFound Is Nothing Then
Set rngTotalFound = wsTotal.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
rngTotalFound.Value = strSearch
End If
.Range(Cells(2, lngCounter).Address, Cells(lngLastRow, lngCounter).Address).Copy _
Destination:=wsTotal.Cells(lngTotalRow, rngTotalFound.Column)
Next lngCounter
End If
End With
End If
Next ws
exit_here:
Set rngTotalFound = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
Zusammenschreiben_Error:
MsgBox "Fehler " & Err.Number & " (" & Err.Description & ") in der Prozedur Zusammenschreiben"
Resume exit_here
End Sub