AW: VBA Werte transponieren oder direkt übertragen
09.03.2018 07:36:17
Axel
Hallo Franz,
Ich hab das Makro jetzt so da stehen:
Sub Auswertung_vorbereiten()
Dim wksData As Worksheet
Dim wksNeu As Worksheet
Dim wksAusw As Worksheet
Dim Zeile As Long, Zelle As Range
If MsgBox("Auswertung mit Daten es aktiven Blatts erstellen?", _
vbOKCancel + vbQuestion, "Daten Auswerten") = vbCancel Then Exit Sub
Set wksData = ActiveSheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wksNeu = ActiveWorkbook.Worksheets.Add(after:=wksData)
wksData.Range("A:B").Copy wksNeu.Cells(1, 1)
wksData.Range("E:I").Copy wksNeu.Cells(1, 3)
With wksNeu
.Name = "DatenNeu"
'Leerstrings aus Zellen in Spalten "Vol1", "Vol2" und "Vol3" beseitigen
For Each Zelle In .Range(.Cells(2, 5), .Cells(Zeile, 7)).Cells
If Trim(Zelle.Text) = "" Then Zelle.ClearContents
Next
'Alle leeren Zellen in Spalten "Vol1", "Vol2" und "Vol3" löschen _
und Inhalte nach links verschieben
.Range(.Cells(2, 5), .Cells(Zeile, 7)).SpecialCells(xlCellTypeBlanks) _
.Delete Shift:=xlToLeft
'Spaltentitel "Vol2" und "Vol3" löschen
.Range(.Cells(1, 6), .Cells(1, 7)).Delete
'"Vol1" ändern in "Vol"
.Cells(1, 5) = "Vol"
'neues Blatt anlegen für Auswertung per Pivot-Bericht
Set wksAusw = ActiveWorkbook.Worksheets.Add(after:=wksNeu)
wksAusw.Name = "Auswertung"
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
.Range(.Cells(1, 1), .Cells(Zeile, 6))) _
.CreatePivotTable TableDestination:=wksAusw.Cells(4, 1), TableName:="PivotTable1"
End With
With wksAusw.PivotTables(1)
With .PivotFields("NL-Nr.")
.Orientation = xlColumnField
.Position = 1
End With
With .PivotFields("Produkt")
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields("Vol"), "Volumen", xlSum
.RowAxisLayout xlTabularRow
ActiveWorkbook.ShowPivotTableFieldList = False
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
An der Stelle
'Leerstrings aus Zellen in Spalten "Vol1", "Vol2" und "Vol3" beseitigen
For Each Zelle In .Range(.Cells(2, 5), .Cells(Zeile, 7)).Cells
läuft's in den Debugg. Liegt wahrscheinlich daran, dass ich den Part:
wksData.Range("A:B").Copy wksNeu.Cells(1, 1)
wksData.Range("E:I").Copy wksNeu.Cells(1, 3)
abweichend habe. Bis dahin werden alle Spalten korrekt übertragen. Jetzt müsste der Part kommen, wo alle befüllten Zellen untereinander geschrieben werden, oder?
Danke und Gruß
Axel