PDA

Vollständige Version anzeigen : Makro um Tabelle bis zum heutigen Tag zu erweitern


Derivator
29.04.2009, 10:58
Hallo zusammen,

ich habe ein kleines Excel VBA Problem.
Ich habe eine Tabelle, die linke Spalte ist eine fortlaufende Datumszeitreihe. Wichtig ist, dass nur Wochentage enthalten sind (Also keine Wochenenden und Feiertage)
die Spalten rechts daneben enthalten Renditedaten von Aktien.

Ich möchte nun einen Button, um per Macro die Tabelle immer bis zum aktuellen Datum erweitern,
daher die letzte Zeile kopieren (Diese enthält eine Abfrageformel) und anschließend möchte ich die
Tabelle (bis auf die letzte Zeite) kopieren und als Werte & Zahlenformat einfügen.
Ich arbeite relativ selten mit VBA, und habe momentan keine Idee wie ich das lösen kann...

Kann mir bitte jemand weiterhelfen?

ich hänge die Datei an um es anschaulicher zu machen:
ggf. nicht über das #N/A Requesting wundern...
diese Zeile soll kopiert werden, und die Tabelle bis zum aktuellen Datum gefüllt werden

Vielen Dank!

MFG Derivator

NoNet
29.04.2009, 12:19
Hallo Jochen,

dieses Makro erfüllt Deine Anforderung :
Sub DatumBisHeuteOhneWochenendenAuffuellen()
Dim lngZ As Long
lngZ = Cells(Rows.Count, 1).End(xlUp).Row 'Letzte belegte Zelle der Spalte A ermitteln

If IsDate(Cells(lngZ, 1)) Then 'Wenn in der letzten Zelle ein Datum steht
While Cells(lngZ, 1).Value < Date
lngZ = lngZ + 1
If Application.Weekday(Cells(lngZ - 1, 1), 2) < 5 Then 'Bei Wochentagen Mo - Do :
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 1 '1 Tag nach vorherigem Datum addieren
Else 'Falls vorheriger Wochentag = Freitag : 3 Tage addieren (=> Montag)
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 3 'Fr. + 3 Tage = Montag
End If
Wend
End If
End Sub
Beachte aber bitte, dass hierin noch keine Feiertage berücksichtigt werden !

EarlFred
29.04.2009, 12:28
Hallo zusammen,

Beachte aber bitte, dass hierin noch keine Feiertage berücksichtigt werden !

...die ja landesspezifisch sind und somit ohnehin nur schwer in einen allgemeingültigen Code einbindbar sind.

Ich würde daher eine separate Liste aller Feiertage erstellen (entweder innerhalb des Makros oder auf einem Blatt der Arbeitsmappe) und diese zusätzlich zu NoNets Makro auf Übereinstimmung prüfen...

Alternative, ohne VBA, aber vergleichbares Schema: Verwenden der Funktion Arbeitstag nach Aktivierung des AddIns Analysetools.

Grüße
EarlFred

Derivator
29.04.2009, 12:34
Hi Nonet,

Vielen Dank für die schnelle Hilfe!
Funktioniert so weit super!

Wo muss ich an dem code nun noch etwas ändern, damit er mir die leeren Zeilen / Spalten neben dem "neu" erschaffenen Datum mit der letzten Zeile "füllt", und dann die gesamte Tabelle (ohne die letzte Zeile) kopiert und als "Wert & Zahlenformat" wieder einfügt?

Danke

Gruß

Derivator
29.04.2009, 12:36
Hi Earlfread,

Danke für den Hinweis!
Ich werde die Taten zusätzlich in ein zusätzliches Tabellenblatt einpflegen

Grüße

NoNet
29.04.2009, 13:14
Hallo Derivator,

so sollte es funktionieren :
Sub DatumBisHeuteOhneWochenendenAuffuellen()
Dim lngZ As Long, lngLZ As Long
lngLZ = Cells(Rows.Count, 1).End(xlUp).Row 'Letzte belegte Zelle der Spalte A ermitteln
lngZ = lngLZ

If IsDate(Cells(lngZ, 1)) Then 'Wenn in der letzten Zelle ein Datum steht
While Cells(lngZ, 1).Value < Date
lngZ = lngZ + 1
If Application.Weekday(Cells(lngZ - 1, 1), 2) < 5 Then 'Bei Wochentagen Mo - Do :
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 1 '1 Tag nach vorherigem Datum addieren
Else 'Falls vorheriger Wochentag = Freitag : 3 Tage addieren (=> Montag)
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 3 'Fr. + 3 Tage = Montag
End If
Wend

'Eingefüghte Zeilen mit Werten füllen - ausser der letzten Zeile (<= Funktion)
If lngZ > lngLZ Then
Cells(lngLZ, 2).Resize(, 4).Copy
Cells(lngLZ + 1, 2).Resize(lngZ - lngLZ, 4).Select
ActiveSheet.Paste
Cells(lngLZ, 2).Resize(lngZ - lngLZ, 4).Copy
Cells(lngLZ, 2).Resize(lngZ - lngLZ, 4).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(lngZ, 1).Select
End If
End If
End Sub

Derivator
29.04.2009, 14:05
Hi Nonet,

Makro funktioniert perfekt! Super, danke Dir!

Noch eine letzte Frage,
ich möchte dieses Makro nun auf mehrere Tabellenblätter anwenden, die teilweise unterschiedlich viele Spalten haben.

ich habe jetzt angefangen jeweils
Sheets("Aktien").Select

davor zu setzten, und den Code jeweils drunter zu kopieren.
Unten habe ich dann entsprechend der Spaltenanzahl manuell angepasst.

Gibt es dafür auch eine schönere Lösung?
EInen Befehl der in einer Schleife durch alle Tabellenblätter geht? bzw. bestimmte Tabellenblätter auswählt, ohne dass ich den ganzen code erneut brauche?


'Eingefügte Zeilen mit Werten füllen - ausser der letzten Zeile (<= Funktion)
If lngZ > lngLZ Then
Cells(lngLZ, 2).Resize(, 4).Copy
Cells(lngLZ + 1, 2).Resize(lngZ - lngLZ, 4).Select
ActiveSheet.Paste
Cells(lngLZ, 2).Resize(lngZ - lngLZ, 4).Copy
Cells(lngLZ, 2).Resize(lngZ - lngLZ, 4).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(lngZ, 1).Select
End If
End If


Gibt es dafür auch eine schönere Lösung?
EInen Befehl der in einer Schleife durch alle Tabellenblätter geht? bzw. bestimmte Tabellenblätter auswählt, ohne dass ich den ganzen code erneut brauche?

Danke für die Hilfe!

Grüße

Derivator
29.04.2009, 14:14
Hi,

für die unterschiedliche Spaltenzahl in den Tabellenblättern habe ich eine Lösung:

Aber für das durchlaufen der Tabellenblätter könnte ich noch Hilfe gebrauchen :)





Sub DatumBisHeuteOhneWochenendenAuffuellen()
Dim lngZ As Long, lngLZ As Long
lngLZ = Cells(Rows.Count, 1).End(xlUp).Row 'Letzte belegte Zelle der Spalte A ermitteln
lngZ = lngLZ
LngLS = Cells(10, Columns.Count).End(xlToLeft).Column 'Letzte belegte Zelle der Zeile 10 ermitteln


If IsDate(Cells(lngZ, 1)) Then 'Wenn in der letzten Zelle ein Datum steht
While Cells(lngZ, 1).Value < Date
lngZ = lngZ + 1
If Application.Weekday(Cells(lngZ - 1, 1), 2) < 5 Then 'Bei Wochentagen Mo - Do :
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 1 '1 Tag nach vorherigem Datum addieren
Else 'Falls vorheriger Wochentag = Freitag : 3 Tage addieren (=> Montag)
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 3 'Fr. + 3 Tage = Montag
End If
Wend

'Eingefügte Zeilen mit Werten füllen - ausser der letzten Zeile (<= Funktion)
If lngZ > lngLZ Then
Cells(lngLZ, 2).Resize(, LngLS).Copy
Cells(lngLZ + 1, 2).Resize(lngZ - lngLZ, LngLS).Select
ActiveSheet.Paste
Cells(lngLZ, 2).Resize(lngZ - lngLZ, LngLS).Copy
Cells(lngLZ, 2).Resize(lngZ - lngLZ, LngLS).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(lngZ, 1).Select
End If
End If
End Sub

NoNet
29.04.2009, 14:22
Hallo D.,

Du könntest das Makro aus einem anderen Makro mit Parameterübergabe (Blattname, Anzahl Spalten) aufrufen :

Sub DatumInMehrerenSheetsAuffuellen()
'Aufruf des Makros mit Übergabe des Blattnamen und der Spaltenanzahl als Parameter
DatumBisHeuteOhneWochenendenAuffuellen "Aktien", 4 'Blatt "Aktien" mit 4 Spalten
DatumBisHeuteOhneWochenendenAuffuellen "Hurra", 3 'Blatt "Hurra" mit 3 Spalten
DatumBisHeuteOhneWochenendenAuffuellen "Suppa1", 5 'Blatt "Suppa1" mit 5 Spalten
'etc.
End Sub

Sub DatumBisHeuteOhneWochenendenAuffuellen(strBlattname, intSpalten)
'Dieses Makro bitte in ein allgemeines Modul kopieren (z.B. "Modul1") !!
Dim lngZ As Long, lngLZ As Long

Sheets(strBlattname).Select

lngLZ = Cells(Rows.Count, 1).End(xlUp).Row 'Letzte belegte Zelle der Spalte A ermitteln
lngZ = lngLZ

If IsDate(Cells(lngZ, 1)) Then 'Wenn in der letzten Zelle ein Datum steht
While Cells(lngZ, 1).Value < Date
lngZ = lngZ + 1
If Application.Weekday(Cells(lngZ - 1, 1), 2) < 5 Then 'Bei Wochentagen Mo - Do :
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 1 '1 Tag nach vorherigem Datum addieren
Else 'Falls vorheriger Wochentag = Freitag : 3 Tage addieren (=> Montag)
Cells(lngZ, 1).Value = Cells(lngZ - 1, 1) + 3 'Fr. + 3 Tage = Montag
End If
Wend

'Eingefüghte Zeilen mit Werten füllen - ausser der letzten Zeile (<= Funktion)
If lngZ > lngLZ Then
Cells(lngLZ, 2).Resize(, intSpalten).Copy
Cells(lngLZ + 1, 2).Resize(lngZ - lngLZ, intSpalten).Select
ActiveSheet.Paste
Cells(lngLZ, 2).Resize(lngZ - lngLZ, intSpalten).Copy
Cells(lngLZ, 2).Resize(lngZ - lngLZ, intSpalten).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(lngZ, 1).Select
End If
End If
End Sub

Derivator
29.04.2009, 14:35
Hmm, oder so.

Vielen Dank für die Hilfe und Anregungen... Du hast mir eine lange Nacht erspart

Cheers

PS: Wie kann man Themen denn als "erledigt" markieren?