VBA Werte transponieren oder direkt übertragen

Forumthread: VBA Werte transponieren oder direkt übertragen

06.03.2018 14:32:46

Axel

Hallo zusammen,
in der mitgesandten Datei
https://www.herber.de/bbs/user/120237.xlsx
ist auszugsweise oben die Datenbasis und darunter das Zielbild, das in ein anderes Tabellenblatt übertragen werden soll.
Roter Kasten: die Daten wiederholen sich in der Datenbasis untereinander mehrfach
Rot durchkreuzt: diese Daten werden nicht mit übertragen
Die Produkte, die in der Datenbasis untereinander stehen, sollen im Zieltabellenblatt nebeneinander stehen. Zu beachten ist, dass unterschiedliche Produkte die Volumina in unterschiedlichen Spalten ausweisen (max 3 Spalten).
Bisher habe ich das mehr oder weniger händig und per SVERWEIS gemacht und anschließend alles als Wertekopie überschrieben. Aber das muss doch auch anders gehen... Das sind 4 mal rund 700 Zeilen und auch wenn die Tätigkeit nur quartalsweise anfällt, wäre eine schnellere Lösung hilfreich...
Vielleicht gibt es auch eine ganz andere Lösung ohne den Umweg des Transponierens.
Letztendlich soll aus der 700 Zeilen-Matrix ein bestimmter Wert entnommen werden abhängig von der NL-Nr und vom Produkt. Das Problem ist halt, dass der Wert in 3 verschiedenen Spalten stehen kann.
Vielen Dank vorab für eure Unterstützung und Anregungen.
Gruß
Axel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: VBA Werte transponieren oder direkt übertragen

07.03.2018 06:41:21

fcs

Hallo Axel,
ich würde für weitere Auswertungen nur die drei Vol-Spalten zu einer Spalte zusammenfassen und die Auswertungen per Pivot-Tabllenbericht machen.
Gruß
Franz

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:D").Copy wksNeu.Cells(1, 1)
wksData.Range("H:K").Copy wksNeu.Cells(1, 5)
With wksNeu
.Name = "DatenNeu"
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
For Each Zelle In .Range(.Cells(2, 6), .Cells(Zeile, 8)).Cells
If Trim(Zelle.Text) = "" Then Zelle.ClearContents
Next
.Range(.Cells(2, 6), .Cells(Zeile, 8)).SpecialCells(xlCellTypeBlanks).Delete Shift:= _
xlToLeft
.Range(.Cells(1, 7), .Cells(1, 8)).Delete
.Cells(1, 6) = "Vol"
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

AW: VBA Werte transponieren oder direkt übertragen

07.03.2018 07:17:36

Axel

Guten Morgen Franz,
vielen Dank für Deine Mühe. Hammer!
Das Makro läuft in den Debugg bei "With .PivotFields("Produkt")"
Ich habe auch gesehen, dass nicht die richtigen Spalten behalten werden. Außerdem werden die Zahlen aus Spalte A transponiert (auch, wenn es danach nicht weitergeht). Ich versuche heute mal zwischendurch, den Code zu verstehen und ggf abzuändern und melde mich wieder. Heute bin ich allerdings fast den ganzen Tag in Terminen, also werde ich mich wahrscheinlich erst morgen wieder melden.
Danke nochmals und Gruß
Axel

AW: VBA Werte transponieren oder direkt übertragen

07.03.2018 08:04:05

Axel

Hi Franz,
ich bin mal schnell über das Makro geflogen und hab es wie folgt abgeändert:

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 des 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"
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
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("Name")
.Orientation = xlColumnField
.Position = 1
End With
With .PivotFields("NL-Nr.")
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields("Ist YTD Ertr."), "Volumen", xlSum
.RowAxisLayout xlTabularRow
ActiveWorkbook.ShowPivotTableFieldList = False
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Der Ansatz ist gut.
Die Herausforderung besteht noch darin, dass die Volumina bestimmter Produkte in unterschiedlichen Spalten stehen, das wird hier noch nicht berücksichtigt. Es wird nur eine Volumensspalte in die Pivottabelle geladen. Das passt bei den meisten Produkten nicht, so dass dort 0 steht. Es wäre auch nicht zielführend, weitere Felder hinzuzufügen, dann wird die Tabelle auf andere Weise unübersichtlich.
Man müsste soetwas formulieren wie: Prüfe in jeder Zeile, ob in den drei Volumensspalten ein Wert steht und dann nimm diesen Wert.
Danke aber vielmals.
Axel

AW: VBA Werte transponieren oder direkt übertragen

07.03.2018 12:08:16

fcs

Hallo Axel,
das Verschieben der Inhalte aus Vol2 und Vol3 nach Vol1 hatte ich eigentlich schon drin.
Die Zeilen hast du baer bei deiner Überarbeiten gelöscht/nicht angepasst.
Nachfolgend 2 Varianten wie man es machen könnte.
Die nummern der Spalten musst du ggf. nochmals anpassen, das jetzt scheinbar Verschiebungen im Vegleich zu deiner Beispieldatei gegeben hat.
Gruß
Franz

'###    Leere Zellen löschen und Inhalte nach links verschieben   ####
With wksNeu
.Name = "DatenNeu"
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'ab hier neu
'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
'bis hier neu
Set wksAusw = ActiveWorkbook.Worksheets.Add(after:=wksNeu)
'###    oder Inhalte der einzelnen Zellen prüfen   ####
With wksNeu
.Name = "DatenNeu"
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'ab hier neu
Dim Zei As Long, Spa As Long
'Zellinhalte in Spalten "Vol2" und "Vol3" prüfen und ggf. in Spalte "Vol1" eintragen
For Zei = 2 To Zeile
For Spa = 6 To 7
If Trim(.Cells(Zei, Spa).Text)  "" _
And .Cells(Zei, Spa).Value > 0 Then
.Cells(Zei, 5).Value = .Cells(Zei, Spa).Value
Exit For
End If
Next
'"Vol2" und "Vol3" löschen und Inhalte nach links verschieben
.Range(.Cells(1, 6), .Cells(1, 7)).EntireColumn.Delete Shift:=xlToLeft
'"Vol1" ändern in "Vol"
.Cells(1, 5) = "Vol"
'neues Blatt anlegen für Auswertung per Pivot-Bericht
'bis hier neu
Set wksAusw = ActiveWorkbook.Worksheets.Add(after:=wksNeu)

AW: VBA Werte transponieren oder direkt übertragen

07.03.2018 12:47:04

Axel

Hi Franz,
vielen Dank. Ich komme wahrscheinlich erst am Freitag morgen dazu, mir das genauer anzuschauen. Ich melde mich aber auf jeden Fall dazu.
Danke für Deine Unterstützung.
Axel

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

AW: VBA Werte transponieren oder direkt übertragen

10.03.2018 02:32:30

fcs

Hallo Axel,
du hast eine wichtige Code-Zeile nicht übernommen oder versehentlich gelöscht.

            Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row

Dadurch ist Zeile = 0 und das Makro läuft in den Fehler.
Die Code-Zeile musst du hoer einfügen:

        .Name = "DatenNeu"
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'Leerstrings aus Zellen in Spalten "Vol1", "Vol2" und "Vol3" beseitigen
For Each Zelle In .Range(.Cells(2, 5), .Cells(Zeile, 7)).Cells

Gruß
Franz

AW: VBA Werte transponieren oder direkt übertragen

12.03.2018 08:58:51

Axel

Guten Morgen Franz,
ich hab die Zeile eingefügt. Nun läuft das Makro an dieser Stelle in den Debug:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
.Range(.Cells(1, 1), .Cells(Zeile, 6))) _
.CreatePivotTable TableDestination:=wksAusw.Cells(4, 1), TableName:="PivotTable1"
Fehlermeldung: "Dieser Befehl setzt mindestens zwei Zeilen voraus.... "
Sagt Dir das was?
Gruß
Axel

Beliebteste Forumthreads (12 Monate)

VBA Werte transponieren oder direkt übertragen

Forumthread: VBA Werte transponieren oder direkt übertragen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

VBA Werte transponieren oder direkt übertragen

Forumthread: VBA Werte transponieren oder direkt übertragen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread