Zellbereiche per Makro kopieren

[Shadow]

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

[Kuwer]

Hallo Basti,

Du weißt schon, dass ich keine aktuelle Datei zum Testen habe? :17:

Gruß Uwe

[Shadow]

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

[Kuwer]

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

[Shadow]

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

[Kuwer]

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

[Shadow]

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

[Kuwer]

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

[Shadow]

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

[Kuwer]

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