Zellbereiche per Makro kopieren

[Shadow]

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!

[Shadow]

Hat denn keiner eine Idee oder ist das per Makro einfach nicht möglich?  :22:

[Kuwer]

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

[Shadow]

Vielen Dank Kuwer das werde ich gleich mal testen.

[Shadow]

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!

[Kuwer]

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

[Shadow]

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

[Kuwer]

Hallo Basti,

das Grundgerüst hast Du. Anpassungen an (nun andere) tatsächliche Gegebenheiten überlasse ich Dir.

Gruß Uwe

[Shadow]

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

[Kuwer]

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.