AW: Nachfrage an Franz und Michael
20.06.2015 09:42:18
fcs
Hallo Thomas,
hier das Makro angepasst, so dass Daten im Blatt "Abrechnung" eingetragen werden und zusätzlich die Werte aus den Spalten A und B übernommen werden.
Gruß
Franz
Sub KopiereGroessere()
Dim wks As Worksheet
Dim wksZiel As Worksheet
Dim arrData, ZeileDat As Long
Dim arrErgebnis(), ZeileErg As Long
Dim Spalte As Long
Set wks = ActiveSheet
Set wksZiel = ActiveWorkbook.Worksheets("Abrechnung")
For Spalte = 13 To 15 'M bis O
With wks
'letzte Datenzeile in Spalte
ZeileDat = .Cells(.Rows.Count, Spalte).End(xlUp).Row
If ZeileDat = 1 Then
'Sonderfall nur Daten in Zeile 1 bzw. Spalte leer
If .Cells(1, Spalte).Value "" Then
ZeileErg = ZeileErg + 1
ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
arrErgebnis(1, ZeileErg) = 1
arrErgebnis(2, ZeileErg) = .Cells(1, Spalte).Value
End If
Else
'Daten in Spalte in Array übernehmen
arrData = .Range(.Cells(1, Spalte), .Cells(ZeileDat, Spalte))
'Ergebnisarray vergrößern
ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg + ZeileDat)
'Daten vergleichen und Ergebnisse in Array schreiben
For ZeileDat = 1 To UBound(arrData, 1) - 1
If arrData(ZeileDat, 1) > arrData(ZeileDat + 1, 1) Then
ZeileErg = ZeileErg + 1
arrErgebnis(1, ZeileErg) = ZeileDat
arrErgebnis(2, ZeileErg) = arrData(ZeileDat, 1)
End If
Next
'letzte Zeile ins Ergebnis-Array übernehmen
ZeileErg = ZeileErg + 1
arrErgebnis(1, ZeileErg) = UBound(arrData, 1)
arrErgebnis(2, ZeileErg) = arrData(UBound(arrData, 1), 1)
'Nicht benutzte Zeilen des Ergebnisarrays entfernen
ReDim Preserve arrErgebnis(1 To 2, 1 To ZeileErg)
End If
End With
Next
'Ergebnis-Werte ab Zelle A2 eintragen
Application.ScreenUpdating = False
With wksZiel.Range("A2")
ZeileDat = .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row
'Altdaten löschen
If ZeileDat >= .Row Then
.Offset(0, 0).Resize(ZeileDat - .Row + 1, 4).ClearContents
End If
If ZeileErg > 0 Then
'Ergebnis-Array in Blatt "Abrechnung" einfügen
.Resize(ZeileErg, 2) = Application.WorksheetFunction.Transpose(arrErgebnis)
'eingefügte Daten nach Zeilen-Nummer sortieren - ggf.die nächsten 3 Zeilen _
aktivieren
' With .Resize(ZeileErg, 2)
' .Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo
' End With
'Werte aus Spalten A und B per Formel übernehmen und Formeln durch Werte ersetzen
With .Offset(0, 2).Resize(ZeileErg, 2)
.FormulaR1C1 = "=INDEX('" & wks.Name & "'!C1:C2,RC1,COLUMN(RC[" & (-.Column + 1) _
& "]))"
.Calculate
.Copy
.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End If
'Spaltentitel eintragen
' .Offset(-1, 0) = "Zeile"
' .Offset(-1, 1) = "Wert"
' .Offset(-1, 2) = "Datum"
' .Offset(-1, 3) = "Wert B"
.Parent.Activate
.Select
End With
Application.ScreenUpdating = True
End Sub