Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Zellbereiche per Makro kopieren
#1
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!


Angehängte Dateien
.xlsx   Beispiel.xlsx (Größe: 767,24 KB / Downloads: 14)
Antwortento top
#2
Hat denn keiner eine Idee oder ist das per Makro einfach nicht möglich?  22
Antwortento top
#3
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
Antwortento top
#4
Vielen Dank Kuwer das werde ich gleich mal testen.
Antwortento top
#5
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!
Antwortento top
#6
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
Antwortento top
#7
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
Antwortento top
#8
Hallo Basti,

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

Gruß Uwe
Antwortento top
#9
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
Antwortento top
#10
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.
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste