VBA Intelligente Tabelle automatisch erweitern
19.08.2018 21:08:31
legiminator
ich habe eine Excel-datei für die Arbeitsvorbereitung. Hierfür habe ich ein Arbeitsblatt (Materialliste) in dem ich die Werte für den Auftrag eingebe. In einem anderen Arbeitsblatt (Materialliste Ausgabe) möchte ich die Materiallisten generieren.
Die Materialliste Ausgabe besteht aus einer Intelligenten Tabelle, welche mittels Makro gefüttert wird. die Tabelle hat nur ca. 10 Zeilen. Mein Ziel ist es das nach dem Einfügen der Daten die Tabelle sich automatisch um die benötigten Zeilen erweitert. Dies ist Normalerweis mit eine Intelligenten Tabelle kein Problem, da diese das automatisch macht.
Jetzt kommt die Besonderheit an der Sache:
Im Arbeitsblatt (Materialliste) wird jeder Datensatz in eine Zeile über mehrer Zellen geschrieben.
Die Ausgabe im Arbeitsblatt (Materialliste Ausgabe) soll dann aber über zwei Zeilen erfolgen. Zwischen jedem Datensatz soll dann eine Leerzeile sein.
für diese Aktion des Kopierens habe ich bereits ein Makro gefunden und soweit abändern können. Jedoch erweitert sich die intelligente Tabelle nicht automatisch. Gibt es hier einen Trick, ohne VBA oder gibt es evtl einen Code mit dem ich den Bereich der Intelligenten Tabelle automatisch auf meinen Datenbereich erweitern kann?
Sub Materialliste_erstellen()
'Worksheets("Materialliste Ausgabe").Cells.ClearContents'
Worksheets("Materialliste Ausgabe").Select
Range("A5:L1048576").Select
Selection.ClearContents
Dim a As Long, i As Long
Application.ScreenUpdating = False
a = 5
For i = 1 To 10000
With Worksheets("Materialliste")
If .Cells(i, 1) > "" Then
Worksheets("Materialliste Ausgabe").Cells(a, 1).Value = Worksheets("Materialliste").Cells(i, 1). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 2).Value = Worksheets("Materialliste").Cells(i, 2). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 3).Value = Worksheets("Materialliste").Cells(i, 4). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 4).Value = Worksheets("Materialliste").Cells(i, 5). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 5).Value = Worksheets("Materialliste").Cells(i, 6). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 6).Value = Worksheets("Materialliste").Cells(i, 7). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 7).Value = Worksheets("Materialliste").Cells(i, 8). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 8).Value = Worksheets("Materialliste").Cells(i, 9). _
_
_
_
_
_
_
Value
Worksheets("Materialliste Ausgabe").Cells(a, 9).Value = Worksheets("Materialliste").Cells(i, 10) _
_
_
_
_
_
_
.Value
Worksheets("Materialliste Ausgabe").Cells(a, 10).Value = Worksheets("Materialliste").Cells(i, _
_
_
_
_
_
_
11).Value
Worksheets("Materialliste Ausgabe").Cells(a, 11).Value = Worksheets("Materialliste").Cells(i, _
_
_
_
_
_
_
12).Value
Worksheets("Materialliste Ausgabe").Cells(a, 12).Value = Worksheets("Materialliste").Cells(i, _
_
_
_
_
_
_
13).Value
a = a + 1
Worksheets("Materialliste Ausgabe").Cells(a + 0, 2).Value = Worksheets("Materialliste").Cells(i, _
_
_
_
_
_
_
3).Value
Worksheets("Materialliste Ausgabe").Cells(a + 0, 4).Value = Worksheets("Materialliste").Cells(i, _
_
_
_
_
_
_
14).Value
a = a + 2
'Druckbereich automatisch erweitern
Dim P As Long
Dim letzte As Long
letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For P = letzte To 1 Step -1
If Cells(P, 1) "" Then
ActiveSheet.PageSetup.PrintArea = "A1:O" & P
Exit For
End If
Next P
Else
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
vielen Dank schon mal für die Hilfe
Anzeige