Hallo zusammen,
in mehreren Spalten (jeweils von Zeile 2 bis 18002) eines Tabellenblattes (Tabelle 1) stehen Werte, die in ein neues Tabellenblatt (Tabelle 2) kopiert werden sollen. Während die Werte in Tabellenblatt 1 alle untereinander stehen (von 00:00 Uhr Tag 3 bis 12:00 Uhr Tag 15), sollen sie in Tabellenblatt 2 nebeneinander, jeweils von 00:00 Uhr bis 23.59 Uhr, stehen. Da die Werte an Tag 15 nur bis 12:00 Uhr gehen (falls überhaupt so viele Werte vorhanden sind), sollen die fehlenden Werte (von 12:01 Uhr bis 23:59 Uhr) durch "-" aufgefüllt werden. Zusätzlich sollen die Werte der Tage 4 bis 7 nicht in das Tabellenblatt 2 kopiert werden.
Ich würde das ganze gerne über ein Makro machen, jedoch habe ich noch nie ein Makro erstellt und absolut keine Ahnung wie das geht oder aussehen muss. Ist so etwas überhaupt per Makro zu bewerkstelligen?
Damit ihr euch ein Bild davon machen könnt, wie meine Tabelle momentan aussieht und wie sie zukünftig aussehen soll, habe ich ein entsprechendes Beispiel angehängt.
Vielen Dank und viele Grüße!
Hat denn keiner eine Idee oder ist das per Makro einfach nicht möglich? :22:
Hallo Shadow,
markiere eine Zelle der zu übertragenden Messreihespalte und führe dann folgendes Makro aus:
Sub Kuwer()
Dim i As Long, j As Long
Dim varSpalte As Variant
Dim oWs As Worksheet
Set oWs = Worksheets("Tabelle2")
varSpalte = Application.Match(Cells(1, ActiveCell.Column), 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(1, ActiveCell.Column).Value
.Offset(1).Resize(, 9).Value = Split("Day3 Day8 Day9 Day10 Day11 Day12 Day13 Day14 Day15")
End With
End If
For i = 2 To 18002 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, 3).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
End Sub
Vielen Dank Kuwer das werde ich gleich mal testen.
Hallo Kluwer,
das Makro funktioniert, jedoch werden auf dem neuen Tabellenblatt nicht die entsprechenden Werte angezeigt / eingefügt, sondern überall "-".
Wie muss ich das Makro anpassen, dass die Werte angezeigt werden?
Vielen Dank und viele Grüße!
Hallo Shadow,
wie sieht es damit aus?
Sub Kuwer()
Dim i As Long, j As Long
Dim varSpalte As Variant
Dim oWs As Worksheet
Set oWs = Worksheets("Tabelle2")
varSpalte = Application.Match(Cells(1, ActiveCell.Column), 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(1, ActiveCell.Column).Value
.Offset(1).Resize(, 9).Value = Split("Day3 Day8 Day9 Day10 Day11 Day12 Day13 Day14 Day15")
End With
End If
For i = 2 To 18002 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, ActiveCell.Column).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
End Sub
Gruß Uwe
Hallo Uwe,
vielen Dank. Folgende Probleme sind noch vorhanden:
- Als Beschriftung in der verbundenen Zelle wird nicht der Text in Zeile 2 genommen, sondern in Zeile 1
- Die Werte der jeweiligen Tage sind jeweils um zwei Zeilen nach unten verschoben, d. h. sie beginnen zwei Zeilen zu früh (und erhalten damit noch die letzten beiden Werte des vorangegangenen Tages. Im Fall von Tag 3 wird erst ein "-" und danach die Überschrift wiedergegeben, bevor die Werte kommen)
- An Tag 8 sind nicht die Werte von Tag 8 aufgelistet, sondern von Tag 3 (an den Tagen 9 bis 15 sind die richtigen Werte zugeordnet)
Und noch eine weitergehende Frage: Gibt es Möglichkeit die Werte aus allen Zeilen (bzw. jeweils aus der ersten Zeile) zu markieren und über das Makro entsprechend neu im Tabellenblatt 2 anordnen zu lassen oder muss das Makro für jeden Versuch (d. h. jede Spalte) einzeln ausgeführt werden?
Viele Grüße,
Basti
Hallo Basti,
das Grundgerüst hast Du. Anpassungen an (nun andere) tatsächliche Gegebenheiten überlasse ich Dir.
Gruß Uwe
Hallo Uwe,
die meisten Punkte konnte ich mit Trial and Error ändern (wie gesagt ich habe absolut keine Ahnung von Makros). Bisweilen sieht das Makro so aus:
Code:
Sub Kuwer()
Dim i As Long, j As Long
Dim varSpalte As Variant
Dim oWs As Worksheet
Set oWs = Worksheets("Tabelle2")
varSpalte = Application.Match(Cells(1, ActiveCell.Column), 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, ActiveCell.Column).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, ActiveCell.Column).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
End Sub
Könntest du mir bitte verraten wie ich das Makro abändern muss, dass es nicht nur die Werte aus einer Spalte nebeneinander in das neue Tabellenblatt kopiert, sondern entsprechend die Werte aus insgesamt 36 Spalten?
Vielen Dank und viele Grüße,
Basti
Hallo Basti,
teste mal so:
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 = 3 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
Geprüft wird im aktiven (Quell-) Blatt in der Zeile 4 auf nichtleere Zellen ab Spalte 3.