PDA

Vollständige Version anzeigen : Zeitreihe mit VBA erstellen


Ghost570
23.04.2009, 14:58
Moin Moin an alle,

ich möchte innerhalb eines Tabellenblattes in Excel eine Zeitreihe erstellen. Hierbei sollen die Werte der Zeile 3 (diese Zeile wird durch eine SVERWEIS-Funktion monatlich mit aktuellen Daten gefüllt) nach unten kopiert werden. Also möchte ich im Januar die Daten in Zeile 4 kopieren, im Februar in Zeile 5 usw. Ich habe mir in der Vergangenheit ein Marko geschrieben, das die Zeitreihe nach rechts fortschreibt. Dieses lautet folgendermaßen:

Sub ZeitreiheSKerstellen()

If MsgBox("Stimmt die Abstimmung der Sachkonten aus dem Datenimport mit der Sachkontenliste überein?", vbYesNo) = vbNo Then Exit Sub
Dim n As Long
Application.ScreenUpdating = False
With Sheets("Zeitreihe SK")
.Range("e8:e81").Copy
.Cells(8, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlValues
.Cells(8, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlFormats
.Range("e86:e109").Copy
.Cells(86, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlValues
.Cells(86, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlFormats
.Range("e114:e231").Copy
.Cells(114, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlValues
.Cells(114, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlFormats
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

Wie muss ich es umschreiben, damit die Zeitreihe nach unten erfolgt?

jinx
23.04.2009, 15:40
Moin, Ghost570,

möglicher Ansatz:

With Sheets("Zeitreihe SK")
.Range(.Cells(3 + Month(Date), 1), .Cells(3 + Month(Date), Columns.Count)).Value = _
.Range(.Cells(3, 1), .Cells(3, Columns.Count)).Value
End With

Ghost570
23.04.2009, 16:09
Hallo Jinx,

ich habe Dir die Datei einfach mal hochgeladen. Sie besteht aus 2 Tabellenblättern.

1. Im Arbeitsblatt "Rechnung" liegen meine Daten. Über den Button "Neue Rechnung" soll ein Marko ausgeführt werden, welche bestimme Daten im Arbeitsblatt "Rechnungsübersicht" historisiert.

Somit sollen die Daten in Zeile 2 im Blatt "Rechnungsübersicht" (diese sind mit den Daten im Blatt "Rechung" verknüpft) in die nächste freie Zeile nach unten kopiert (historisiert) werden.

Kannst Du mir dieses Marko erstellen?

Ich danke Dir im Voraus für deine Mühe!

Ghost

jinx
23.04.2009, 17:04
Moin, Ghost570,

irgendwie hat die Aufgabe in der angehängten Mappe meiner Meinung nach nicht so wirklich viel mit der ursprünglichen Fragestellung gemein... ;) Es werden nur die Bereiche wie gewünscht gelöscht, keine Prüfung auf vollständige Angaben bezüglich Adresse, Kundennr und Artikeln:

Option Explicit

Sub Ghost570()

Dim wsData As Worksheet
Dim wsHist As Worksheet
Dim lngFirstFree As Long

On Error GoTo Ghost570_Error

Set wsData = Sheets("Rechnung")
Set wsHist = Sheets("Rechnungsübersicht")

'erste freie Zeile feststellen
lngFirstFree = Rows.Count
If wsHist.Cells(lngFirstFree, "A").Value <> "" Then
MsgBox "Tabelle Historie gefüllt. Bitte Daten auslagern.", vbExclamation
Exit Sub
Else
lngFirstFree = wsHist.Cells(Rows.Count, "A").End(xlUp).Row + 1
End If

'Umschreiben der Werte
With wsHist
.Range(.Cells(lngFirstFree, 1), .Cells(lngFirstFree, 4)).Value = _
.Range(.Cells(2, 1), .Cells(2, 4)).Value
End With

'Erhöhen der Rechnungsnnumer um 1 und Löschen der Eingabe wie gewünscht
With wsData
.Range("C15").Value = .Range("C15").Value + 1
.Range("RGkdnr, RGArtikel, RGkg").ClearContents
End With

exit_here:
Set wsHist = Nothing
Set wsData = Nothing

On Error GoTo 0
Exit Sub

Ghost570_Error:

MsgBox "Fehler " & Err.Number & " (" & Err.Description & ") in der Prozedur Ghost570 von Modul Modul2"
Resume exit_here

End Sub

Ghost570
23.04.2009, 17:27
Danke,

es funktioniert perfekt.............!!!!

LG Ghost