Guten Morgen Uwe,
vielen Dank für das Makro. Das funktioniert, hat aber noch ein Problem. Die Werte aus genau jeder zweiten Spalte werden nicht in das neue Tabellenblatt kopiert. Die 9 entsprechen Spalten sind komplett leer und enthalten nicht einmal ein "-". Während die zugehörige Überschrift in der verbundenen Zeile nicht wieder gegeben wird, fehlen die Werte.
Viele Grüße,
Basti
Hallo Basti,
Du weißt schon, dass ich keine aktuelle Datei zum Testen habe? :17:
Gruß Uwe
Hallo Uwe,
entschuldige bitte. Hier eine aktuelle Testdatei, in der ich folgendes Makro anwende:
Sub Kuwer2()
Dim i As Long, j As Long
Dim lngSpalteQ As Long
Dim oWs As Worksheet
Dim varSpalte As Variant
Set oWs = Worksheets("Tabelle2")
For lngSpalteQ = 5 To Cells(4, Columns.Count).End(xlToLeft).Column
varSpalte = Application.Match(Cells(1, lngSpalteQ), oWs.Rows(1), 0)
If IsError(varSpalte) Then
varSpalte = oWs.Cells(1, Columns.Count).End(xlToLeft).Column
If varSpalte = 1 Then
varSpalte = 2
Else
varSpalte = varSpalte + 9
End If
With oWs.Cells(1, varSpalte).Resize(, 9)
.Merge
.HorizontalAlignment = xlCenter
.Value = Cells(2, lngSpalteQ).Value
.Offset(1).Resize(, 9).Value = Split("Day3 Day8 Day9 Day10 Day11 Day12 Day13 Day14 Day15")
End With
End If
For i = 4 To 18004 Step 1440
Select Case Cells(i, 1).Value
Case 4, 5, 6, 7
Case Else
With oWs.Cells(3, varSpalte + j).Resize(1440)
Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
If Application.WorksheetFunction.CountBlank(.Cells) Then
.SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
j = j + 1
End Select
Next i
Next lngSpalteQ
End Sub
Das Makro läuft aufgrund der Datenmenge (meiner richtigen Datei) eine ganze Weile (zumindest bei mir).
Als ich es gerade noch einmal ausgeführt habe, habe ich gemerkt, dass die Werte ab Spalte zwei (#2) nicht fehlen, sondern um die entsprechende Anzahl Spalten (also 9) nach rechts verschoben sind: Die Werte bei #2 fehlen und stehen stattdessen bei #3, die Werte bei #4 fehlen und stehen stattdessen bei #5, usw. Im Tabellenblatt 3 habe ich das mal schematisch aufgeführt. Die Beschriftung in den verbundenen Zeilen hört nach 324 Spalten auf (36 Spalten * 9), während der Inhalt aus diesen 36 Spalten erst nach 639 Spalten aufhört ((36 Spalten * 18) - 9 Spalten von #1).
Durch welchen Teil des Makros kommt es denn zu dieser Verschiebung und wie behebt man sie?
Viele Grüße,
Basti
Hallo Basti,
in der Zeile
varSpalte = Application.Match(Cells(1, lngSpalteQ), oWs.Rows(1), 0)
fehlt die Anpassung an Zeile 2 (rot markiert).
Gruß Uwe
Hallo Uwe,
ich habe die rot markierte 1 versucht an Zeile 2 anzupassen, aber es klappt irgendwie nicht und ich steige zur Zeit auch nicht dahinter warum. Mein Verständnis in diesem Bereich ist wirklich sehr gering. Tut mir also leid, wenn ich das bisher nicht richtig umsetze. Ich habe es u. a. mit
varSpalte = Application.Match(Cells(2, lngSpalteQ), oWs.Rows(1), 0)
und
varSpalte = Application.Match(Cells(5, lngSpalteQ), oWs.Rows(1), 0)
versucht.
Viele Grüße,
Basti
Hallo Basti,
varSpalte = Application.Match(Cells(2, lngSpalteQ), oWs.Rows(1), 0)
ist richtig und funktioniert auch bei mir mit Deiner "Beispiel_aktuell".
Immer daran denken, das vor Ausführung des Makros die Quelltabelle aktiv ist!
Gruß Uwe
Hallo Uwe,
ich habe das Makro
Sub Kuwer2()
Dim i As Long, j As Long
Dim lngSpalteQ As Long
Dim oWs As Worksheet
Dim varSpalte As Variant
Set oWs = Worksheets("Tabelle2")
For lngSpalteQ = 5 To Cells(4, Columns.Count).End(xlToLeft).Column
varSpalte = Application.Match(Cells(2, lngSpalteQ), oWs.Rows(1), 0)
If IsError(varSpalte) Then
varSpalte = oWs.Cells(1, Columns.Count).End(xlToLeft).Column
If varSpalte = 1 Then
varSpalte = 2
Else
varSpalte = varSpalte + 9
End If
With oWs.Cells(1, varSpalte).Resize(, 9)
.Merge
.HorizontalAlignment = xlCenter
.Value = Cells(2, lngSpalteQ).Value
.Offset(1).Resize(, 9).Value = Split("Day3 Day8 Day9 Day10 Day11 Day12 Day13 Day14 Day15")
End With
End If
For i = 4 To 18004 Step 1440
Select Case Cells(i, 1).Value
Case 4, 5, 6, 7
Case Else
With oWs.Cells(3, varSpalte + j).Resize(1440)
Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
If Application.WorksheetFunction.CountBlank(.Cells) Then
.SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
j = j + 1
End Select
Next i
Next lngSpalteQ
End Sub
noch einmal an angehängter Datei getestet (ich würde hier gerne die entsprechende Datei inkl. Makro hochladen, aber dafür ist sie zu groß) und es klappt einfach nicht. An was liegt es denn? Ich habe extra darauf geachtet, dass die Quelltabelle aktiv ist, jedoch verschiebt es mir beispielsweise die Bereiche K3:S1442 immernoch 9 Spalten nach rechts (zu T3:AB1442).
Viele Grüße,
Basti
Hallo Basti,
Fehler gefunden: Durch die hinzugekommene Messreihenschleife muss der Tageszähler j für jeden Durchgang zurückgesetzt werden. Das hatte ich vergessen.
Jetzt sollte es klappen:
Sub Kuwer3()
Dim i As Long, j As Long
Dim lngSpalteQ As Long
Dim oWs As Worksheet
Dim varSpalte As Variant
Set oWs = Worksheets("Tabelle2")
For lngSpalteQ = 5 To Cells(4, Columns.Count).End(xlToLeft).Column
varSpalte = Application.Match(Cells(2, lngSpalteQ), oWs.Rows(1), 0)
If IsError(varSpalte) Then
varSpalte = oWs.Cells(1, Columns.Count).End(xlToLeft).Column
If varSpalte = 1 Then
varSpalte = 2
Else
varSpalte = varSpalte + 9
End If
With oWs.Cells(1, varSpalte).Resize(, 9)
.Merge
.HorizontalAlignment = xlCenter
.Value = Cells(2, lngSpalteQ).Value
.Offset(1).Resize(, 9).Value = Split("Day3 Day8 Day9 Day10 Day11 Day12 Day13 Day14 Day15")
End With
End If
j = 0
For i = 4 To 18004 Step 1440
Select Case Cells(i, 1).Value
Case 4, 5, 6, 7
Case Else
With oWs.Cells(3, varSpalte + j).Resize(1440)
Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
If Application.WorksheetFunction.CountBlank(.Cells) Then
.SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
j = j + 1
End Select
Next i
Next lngSpalteQ
End Sub
Gruß Uwe
Hallo Uwe,
herzlichen Dank!!!! Das funktioniert einwandfrei! Vielen, vielen Dank.
Eine Verständnisfrage noch (so langsam scheine ich Schritt für Schritt dahinter zu kommen wie alles funktioniert). Wenn ich
Select Case Cells(i, 1).Value
Case 4, 5, 6, 7
gegen
Select Case Cells(i, 1).Value
Case 3, 8, 9, 10, 11, 12, 13, 14, 15
in dem Makro austausche, dann kopiert er mir entsprechend nur die Werte von Tag 4, 5, 6 und 7 nebeneinander in das neue Tabellenblatt, richtig?
Und wenn ich
For i = 4 To 18004 Step 1440
Select Case Cells(i, 1).Value
Case 4, 5, 6, 7
Case Else
With oWs.Cells(3, varSpalte + j).Resize(1440)
Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
If Application.WorksheetFunction.CountBlank(.Cells) Then
.SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
gegen
For i = 4 To 18004 Step 1440
Select Case Cells(i, 1).Value
With oWs.Cells(3, varSpalte + j).Resize(1440)
Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
If Application.WorksheetFunction.CountBlank(.Cells) Then
.SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
ersetze, dann kopiert mir das Makro alle Werte von allen Tagen nebeneinander in das neue Tabellenblatt?
Nochmal vielen Dank für deine Hilfe!
Viele Grüße,
Basti
Hallo Basti,
Deine Umsetzungen waren bis auf die letzte richtig, denn wenn man Select Case verwendet, muss auch mindestens eine Case-Zeile vorhanden sein.
Excel hat auch eine sehr gute Hilfe. Setze mal den Cursor im VBA-Editor auf ein
Case und drücke die Taste F1.
Da Du Dir nun Gedanken zur Flexibilisierung gemacht hast, habe ich das Ganze mal entsprechend umgestellt, weil ja bisher die Tage (Anzahl und Überschriften) statisch waren. Das Zielblatt wird immer komplett neu aufgebaut.
Option Explicit
Sub Kuwer4()
Dim i As Long, j As Long
Dim lngSpalteQ As Long
Dim lngSpalteZ As Long
Dim oWsQ As Worksheet ''Quellblatt
Dim oWsZ As Worksheet ''Zielblatt
Dim datTag(0 To 1439, 1 To 1) As Date
''Festlegung des Quellblatts
Set oWsQ = Worksheets("Tabelle1") ''oder auch z.B. = ActiveSheet
''Festlegung des Zielblatts
'Set oWsZ = Worksheets("Tabelle2")
'oWsZ.cells.Delete
''oder neues Blatt erzeugen
Set oWsZ = Worksheets.Add(After:=oWsQ)
''die minütlichen Messzeiten für einen Tag werden in Spalte A eingetragen
For i = 0 To 1439
datTag(i, 1) = TimeSerial(0, i, 0)
Next i
With oWsZ.Cells(3, 1).Resize(1440)
.NumberFormat = "hh:mm"
.Font.Name = "Arial"
'.Font.Bold = True
.HorizontalAlignment = xlCenter
.Value = datTag
End With
''Schleife über alle Messreihen im Quellblatt
For lngSpalteQ = 5 To oWsQ.Cells(4, oWsQ.Columns.Count).End(xlToLeft).Column
''Ermittlung der ersten freien Spalte für Messreihe im Zielblatt
lngSpalteZ = oWsZ.Cells(2, oWsZ.Columns.Count).End(xlToLeft).Column + 1
''Tageszähler zurücksetzen
j = 0
''Schleife durch eine Messreihe mit einer Schrittweite von 1440 Minuten (= 1 Tag)
For i = 4 To 18004 Step 1440
''Tagesnummer aus Spalte A des Quellblatts feststellen und auswerten
Select Case oWsQ.Cells(i, 1).Value
''bei Übereinstimmung mit einem der aufgeführten Elemente ...
Case "" ' 4, 5, 6, 7
''... passiert hier nichts
''wenn es bisher keine Übereinstimmungen gab, greift dieser Abschnitt
Case Else
''die Zeile 3 der Tagesspalte im Zielblatt ist die Referenz für folgende Aktionen
With oWsZ.Cells(3, lngSpalteZ + j)
''Eintrag der Überschrift in Zeile 2 der Tagesspalte
With .Offset(-1)
.Font.Name = "Arial"
.HorizontalAlignment = xlCenter
.Value = "Day" & oWsQ.Cells(i, 1).Value
End With
''Messwerte des Tages werden übertragen
oWsQ.Cells(i, lngSpalteQ).Resize(1440).Copy .Cells(1)
''leere Zellen werden mit einem "-" versehen
If Application.WorksheetFunction.CountBlank(.Resize(1440)) Then
.Resize(1440).SpecialCells(xlCellTypeBlanks).Value = "-"
End If
End With
j = j + 1
End Select
Next i
''Benenung der Messreihe kommt als Zellverbund in Zeile 1 über alle Tagesspalten
With oWsZ.Cells(1, lngSpalteZ).Resize(, j)
.Merge
.HorizontalAlignment = xlCenter
.Value = oWsQ.Cells(2, lngSpalteQ).Value
End With
Next lngSpalteQ
End Sub
Code eingefügt mit: Excel Code Jeanie
Gruß Uwe