Hallo
Ich habe ein Tabellenblatt, welche mit rj + Jahr (z.B. rj09) benannt ist. Nun möchte ich, wenn das Tabellenblatt ausgefüllt ist, das rjxx kopieren und als archiv_rjxx die Werte einfügen (anschliessend noch sperren und drucken). Das rj09 soll nun um 1 aufgezählt werden, also rj10 und die Eingabezellen gelöscht werden.
Leider weiss ich nicht, wie ich meine Frage editieren kann, deshalb antworte ich mir selber.
Ich habe natürlich auch schon viel versucht, zusammenkopiert und getestet.
Sub CommandButton1\_Click()
Prompt = "wirlich?"
DialogArt = vbYesNo + vbExclamation + vbDefaultButton1
Title = "alles finish"
Beep
Antwort = MsgBox(Prompt, DialogArt, Title)
If Antwort = vbYes Then
entsperren
kopieren
drucken
loeschen
sperren
' MeldungEnde
Else
End If
End Sub
Sub entsperren()
Dim wks As Worksheet
For Each wks In Worksheets
wks.Unprotect '"passwort"
Next wks
End Sub
Sub kopieren()
Dim tbname As String
Dim tbzelle As String
Dim loebereich As Range
tbname = ActiveSheet.Range("M01")
On Error Resume Next ' Fehler abfangen falls es bereits ein Tabellenblatt mit diesem Namen gibt
ActiveSheet.Unprotect
ActiveSheet.Copy before:=Sheets(Worksheets.Count)
ActiveSheet.Name = tbname
With ActiveSheet.UsedRange
.Cells.Value = .Cells.Value
ActiveWorkbook.Sheets(2).Name = "" & Range("M03").Value
End With
End Sub
Sub drucken()
ActiveSheet.PrintOut
' ActiveWorkbook.Sheets.Tab.ColorIndex = 10 'rote Farbe für archvierte Tabellenblätter, funktioniert leider nicht
End Sub
Sub loeschen()
Dim loezellen As Range
ActiveSheet.Unprotect
Set loezellen = Union(Range("A8:b17"), Range("A19:a20"), Range("b19:b21"), Range("D8:h21"), \_
Range("a24:a25"), Range("b24:b27"), Range("D24:h27"), \_
Range("a30:a34"), Range("b30:b35"), Range("D30:h35"), \_
Range("a38:a43"), Range("b38:b46"), Range("D38:h46"))
loezellen.ClearContents
End Sub
Sub sperren()
Dim wks As Worksheet
For Each wks In Worksheets
wks.Protect '"passwort"
Next wks
End Sub
Soweit funktioniert vieles. Blöderweise wird jedoch die Kopie bei einem zweiten übertrag nicht in „archiv_rjxx(2)“ sondern in „rjxx(2)“ umbenannt. Am Schluss ist zudem nicht wieder das „Original“ aktiv, sondern die Kopie. Und wenn ich gleich am jammern bin; die Hintergrundfarbe in Rot zu ändern (bei den Kopien) habe ich auch nicht geschaft.
Für Tipps, Korrekturen oder Hilfen bin ich dankbar.
mfg motoremio
Hallo motoremio.
Sub drucken()
ActiveSheet.PrintOut
’ ActiveWorkbook.Sheets.Tab.ColorIndex = 10 'rote Farbe für
archvierte Tabellenblätter, funktioniert leider nicht
End Sub
Hier fehlt doch wahrscheinlich nur die Angabe, um welches Tabellenblatt es sich handeln soll: Sheets(„Blablabla“)…
VG
Carsten
Hallo motoremio.
Am Schluss ist zudem nicht wieder das „Original“ aktiv, sondern die Kopie
Ich denke, an dieser Stelle sollte eine Anweisung in der Art wie „Sheets(„Original“).Activate“ ausreichen, um zum Original zurückzukehren.
Kleiner Tip an dieser Stelle noch: Du könntest vor Deinen Prozeduren die Anweisung „Application.ScreenUpdating = False“ verwenden, um den ganzen Ablauf optisch zu „beruhigen“. Hinterher dann wieder auf „True“ einstellen.
VG
Carsten
Hallo motoremio.
Blöderweise wird jedoch die Kopie bei einem zweiten übertrag nicht in „archiv_rjxx(2)“ sondern in „rjxx(2)“ umbenannt.
Sub kopieren()
Dim tbname As String
Dim tbzelle As String
Dim loebereich As Range
tbname = ActiveSheet.Range(„M01“)
On Error Resume Next ’ Fehler abfangen falls es bereits ein
Tabellenblatt mit diesem Namen gibt
ActiveSheet.Unprotect
ActiveSheet.Copy before:=Sheets(Worksheets.Count)
ActiveSheet.Name = tbname
With ActiveSheet.UsedRange
.Cells.Value = .Cells.Value
ActiveWorkbook.Sheets(2).Name = „“ & Range(„M03“).Value
End With
End Sub
An dieser Stelle kann ich nur Mutmaßungen anstellen. Was bedeutet „zweiter Übertrag“? Ich konnte an keiner Stelle im Code die Zeichenfolge „archiv_“ entdecken, was dann bedeuten würde, dass diese Zeichenfolge irgendwo in einer Tabellenblatt-Zelle steht. Verkette doch die Zeichenfolgen im Code.
Du verwendest die Anweisung „On Error Resume Next“. Das bedeutet ja, dass bei einem Fehler die nächste Anweisung ausgeführt wird. Meine Vermutung ist, dass das nicht so sein darf, da ja ein Tabellenblatt umbenannt wird. Ich denke, Du brauchst eine Fehlerbehandlung mit einer definierten Sprungmarke. Ungefähr so:
Sub kopieren()
Dim tbname As String
Dim tbzelle As String
Dim loebereich As Range
tbname = ActiveSheet.Range("M01")
**On Error GoTo ErrHandler**
ActiveSheet.Unprotect
ActiveSheet.Copy before:=Sheets(Worksheets.Count)
ActiveSheet.Name = tbname
With ActiveSheet.UsedRange
.Cells.Value = .Cells.Value
ActiveWorkbook.Sheets(2).Name = "" & Range("M03").Value
End With
Ende:
Exit Sub
**ErrHandler:**
tbname = IrgendwasAnderes
Resume Ende
End Sub
Jedenfalls solltest Du die Anweisung „On Error Resume Next“ einfach 'mal auskommentieren und dann den Code ausführen, um festzustellen, ob und wo ein Fehler auftritt.
VG
Carsten
Hallo Emio,
Leider weiss ich nicht, wie ich meine Frage editieren kann,
kannst du nicht, nur ein Mod.
Du kannst aber deinen Beitrag rauskopieren, dann den Beitrag löschen solange noch keiner darauf geantwortet hat, dann mit neuem Betreff neu einstellen als Frage.
deshalb antworte ich mir selber.
Geht auch 
Zu deinem Code, benutze bitte Leerzeichen als Einrückungen für If- u.ä. Schleifen, hier dann den Pre-Tag, wird unterhalb des Eingabefensters erklärt.
Soweit funktioniert vieles. Blöderweise wird jedoch die Kopie
bei einem zweiten übertrag nicht in „archiv_rjxx(2)“ sondern
in „rjxx(2)“ umbenannt.
Ich dachte Blatt rjxx soll nach archiv_rjxx umkopiert werden!?
Warum jetzt diese (2)?
Wieso „zweiter“ Übertrag? Soll dann das Blatt archiv_rjxx überschrieben werden?
Am Schluss ist zudem nicht wieder das
„Original“ aktiv, sondern die Kopie.
Aktiviere das Original. Worksheets(„MeinOriginal“).Activate
Und wenn ich gleich am
jammern bin; die Hintergrundfarbe in Rot zu ändern (bei den
Kopien) habe ich auch nicht geschaft.
„Hintergrundfarbe“? Du meinst die Hintergrundfarbe der Tabellenblattnamen unten im Register?
Solls ab XL2002 oder 2003 geben.
Wenn dafür die Syntax ist
xyz.Tab.ColorIndex = 10
so mußt du in xyz das jeweilige Blatt referenzieren.
Wobei mir 10 für Rot suspekt vorkommt.
Gruß
Reinhard
Hallo zusammen
Ich danke Euch ganz herzlich für Eure Antworten. Versuche diese Mal zu verstehen.
Noch eine Erläuterung wegen dem doppelten Übertrag. Im Jahr 09 wird das Tabellenblatt rj09 archiviert. Die Kopie von rj09 wird in archiv_rj09 unbenannt; das Original in rj10 (=rj09 +1) unbenannt und die Inhalte gelöscht. Möglicherweise gibt es nochmals einträge fürs 2009, also muss nochmals ein Übertrag gemacht werden. Diesesmal müsste die Archiv-Datei doch „archiv_rj09(2)“ heissen. Oder?
Nun habe ich noch etwas angepasst. Die Tabellenblattbenennung wird nicht aus der Zelle ausgelesen, sondern durch folgenden Befehl erreicht:
ActiveSheet.Name = "rj" & Format(DateSerial(Year(Date) + 1, Month(Date) + 1, lngCounter), "YY")
@Reinhard: Was meintest Du mit
Zu deinem Code, benutze bitte Leerzeichen als Einrückungen für If- u.ä. Schleifen, hier dann den Pre-Tag, wird unterhalb des Eingabefensters erklärt.
Könnt ihr mir noch erklären, ob mein Makro in ein Objekt (=Tabellenblatt) oder in Module gespeichert werden sollte?
Danke
motoremio
tabellenblatt kopieren und umbenennen
Hallo Forumler
Nun dachte ich schon, mein Code ist gut. Aber die Sache mit der Umbenennung läuft noch nicht rosig.
Hier mal mein Code
Sub alles()
Dim wks As Worksheet
Dim tbname_aktuell As String
Dim tbname_archiv As String
Dim tbzelle As String
Dim loebereich As Range
Dim lngCounter As Long
Dim i As Integer
Dim loezellen As Range
Dim strStartBlatt As String
i = 1
tbname_aktuell = „rj“ & Format(DateSerial(Year(Date) + 1, Month(Date), lngCounter), „YY“)
tbname_archiv = „archiv_rj“ & Format(DateSerial(Year(Date), Month(Date), Day(Date)), „YY“) & „(“ & i & „)“
ActiveSheet.Name = tbname_aktuell
ActiveSheet.Unprotect
ActiveSheet.Copy before:=Sheets(Worksheets.Count)
With ActiveSheet.UsedRange
.Cells.Value = .Cells.Value
On Error GoTo ErrHandler
ActiveSheet.Name = tbname_archiv
End With
Ende:
ErrHandler:
’ MsgBox „Wenn der Name 'archiv_rjYY(1), soll ein die letzte Zahl _
’ hochgezählt werden; also 'archiv_rjYY(2), etc“
Resume Next
ActiveSheet.PrintOut
ActiveWorkbook.Sheets(tbname_archiv).Tab.ColorIndex = 3
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlNoSelection
Sheets(tbname_aktuell).Activate
Set loezellen = Union(Range(„A8:b17“), Range(„A19:a20“), Range(„b19:b21“), Range(„D8:h21“), _
Range(„a24:a25“), Range(„b24:b27“), Range(„D24:h27“), _
Range(„a30:a34“), Range(„b30:b35“), Range(„D30:h35“), _
Range(„a38:a43“), Range(„b38:b46“), Range(„D38:h46“))
loezellen.ClearContents
ActiveSheet.Protect
Range(„a8“).Select
End Sub
Das zweite jedoch kleiner Problem ist halt immer noch die Sache bei mehreren Überträgen im selben Jahr. Nochmals die Erklärung…
Im Jahr 09 wird das Tabellenblatt rj09 archiviert. Die Kopie von rj09 wird in archiv_rj09 unbenannt; das Original in rj10 (=rj09 +1) unbenannt und die Inhalte gelöscht. Möglicherweise gibt es nochmals einträge fürs 2009, also muss nochmals ein Übertrag gemacht werden. Diesesmal müsste die Archiv-Datei doch „archiv_rj09(2)“ heissen.
Wäre super froh, wenn mir jemand helfen könnte.
mfg motoremio
Das zweite jedoch kleiner Problem ist halt immer noch die
Sache bei mehreren Überträgen im selben Jahr. Nochmals die
Erklärung…
Im Jahr 09 wird das Tabellenblatt rj09 archiviert. Die Kopie
von rj09 wird in archiv_rj09 unbenannt; das Original in rj10
(=rj09 +1) unbenannt und die Inhalte gelöscht. Möglicherweise
gibt es nochmals einträge fürs 2009, also muss nochmals ein
Übertrag gemacht werden. Diesesmal müsste die Archiv-Datei
doch „archiv_rj09(2)“ heissen.
Hallo Motoremio,
Sub Archiv()
Dim wks As Worksheet, Blatt As String, Nr As Integer, NichtNeu As Boolean
Dim Kopie As String
Blatt = ActiveSheet.Name
If Blatt "rj" & Format(Date, "YY") Then Exit Sub
For Each wks In ThisWorkbook.Worksheets
If wks.Name = "rj" & CInt(Format(Date, "YY")) + 1 Then NichtNeu = True
If wks.Name Like "archiv\_" & Blatt & "\*" Then
Nr = Nr + 1
End If
Next wks
Kopie = "archiv\_" & Blatt
If Nr \>= 1 Then Kopie = Kopie & "(" & Nr + 1 & ")"
Worksheets(Blatt).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Kopie
If NichtNeu = False Then
Worksheets(Blatt).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "rj" & CInt(Format(Date, "YY")) + 1
Range("A8:b17, A19:a20, b19:b21, D8:h21, a24:a25, b24:b27,D24:h27").ClearContents
Range("a30:a34, b30:b35, D30:h35, a38:a43, b38:b46, D38:h46").ClearContents
End If
Worksheets(Blatt).Activate
End Sub
Gruß
Reinhard
Besten Dank Reinhard
Nun sehe ich, wie es anderen ergeht, wenn ich Ihre CSS-Codes anpasse… (War erschrocken, wie meine VBA-Kenntnisse schlecht sind).
Auf jedenfall mal besten Dank.
Beim Abspielen des Makro gibt es wie gewünscht eine Kopie (archiv_rjxx) und es entsteht noch eine zweite Kopie (rj_xx + 1). Die ursprüngliche Datei (rjxx) bleibt leider auch. Vielleicht habe ich das zuwenig genau erklärt, aber eigentlich sollte immer nur ein wks zum erfassen sein (wenn bereis ein Übertrag gemacht wurde, dann [nach heutigem Datum 2009] rx10 [zum ausfüllen bereit] und archiv_rx09. Gab es noch keine Einträge ist eben nur rx09 vorhanden. Dann kommt noch die Sache mit dem doppelten Übertrag dazu, welche Du ja perfekt gelöst hast.
Ich hoffe, dass ich mich verständlich ausgedrückt habe.
Habe versucht den Code anzupassen, musste aber passen.
Kannst Du mir nochmals helfen?
Danke
Matthias
Hallo Matthias,
Beim Abspielen des Makro gibt es wie gewünscht eine Kopie
(archiv_rjxx) und es entsteht noch eine zweite Kopie (rj_xx +
1). Die ursprüngliche Datei (rjxx) bleibt leider auch.
Vielleicht habe ich das zuwenig genau erklärt, aber eigentlich
sollte immer nur ein wks zum erfassen sein (wenn bereis ein
Übertrag gemacht wurde, dann [nach heutigem Datum 2009] rx10
[zum ausfüllen bereit] und archiv_rx09. Gab es noch keine
Einträge ist eben nur rx09 vorhanden. Dann kommt noch die
Sache mit dem doppelten Übertrag dazu, welche Du ja perfekt
gelöst hast.
Hallo Matthias,
so wie ich es sehe sind da nur kleine Dinge im Code anzupassen, aber vielleicht schiele ich )
09 steht für das aktuelle Jahr.
Pro Jahr gibt es ein Blatt wie z.b. rj09.
Beim ersten Speichern soll das Blatt archiv_rj09 und das Blatt rj10 erzeugt werden. In rj10 sollen einige Zellinhalte gelöscht werden.
Das Blatt rj09 soll danach gelösht werden.
Korrekt?
Nun ergeben sich Änderungen in archiv_rj09, dann soll das als Blatt archiv_rj09(2) gespeichert werden.
archiv_rj09 soll erhalten bleiben?
rj10 bleibt davon unbehelligt?
Korrekt?
Wenn nun archiv_rj09(2), archiv_rj09(3),archiv_rj09(4) existieren, soll es dann dem Makro egal sein welche grad archiviert werden soll, es wird immer archiv_rj09(5) daraus?
(*hüstel* so ganz habe ich diese Frage von mir auch nicht verstanden, ich hoffe du kannst damit was anfangen und erahnen was ich meine *lächel*)
Das mit Blattschutz bzw. Protect habe ich bewußt erstmal weggelassen.
Wenn der Gesamtcode steht kann man das leicht ei9nbauen, aber in der Testphase ist das hinderlich wie ausgeblendete Blätter usw.
Gruß
Reinhard
Habe es doch noch geschaft…
Sub Archiv()
Dim wks As Worksheet, Blatt As String, Nr As Integer, NichtNeu As Boolean
Dim Kopie As String
Blatt = ActiveSheet.Name
ActiveSheet.Unprotect
If Blatt "rj" & Format(Date, "YYYY") Then
If MsgBox("Falsches Rechnungsjahr!" & Chr(10) & "Tabellenblatt in rj" & CInt(Format(Date, "yyyy")) & " umbenennen?", vbYesNo + vbQuestion, "Tabellenblattbeschriftung!!") = vbYes Then
ActiveSheet.Name = "rj" & CInt(Format(Date, "YYYY"))
Blatt = ActiveSheet.Name
Else:
MsgBox "so hilf Dir selber!"
Exit Sub
End If
End If
For Each wks In ThisWorkbook.Worksheets
If wks.Name = "rj" & CInt(Format(Date, "YYYY")) + 1 Then NichtNeu = True
If wks.Name Like "archiv\_" & Blatt & "\*" Then
Nr = Nr + 1
End If
Next wks
Kopie = "archiv\_" & Blatt
If Nr \>= 1 Then Kopie = Kopie & "(" & Nr + 1 & ")"
Worksheets(Blatt).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Kopie
Range("a1:j60").Value = Range("a1:j60").Value
ActiveWorkbook.Sheets(Kopie).Tab.ColorIndex = 3
ActiveSheet.PrintOut
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlNoSelection
If NichtNeu = False Then
Worksheets(Blatt).Activate
ActiveSheet.Name = "rj" & CInt(Format(Date, "YYYY")) + 1
Range("A8:b17, A19:a20, b19:b21, D8:h21, a24:a25, b24:b27, D24:h27").ClearContents
Range("a30:a34, b30:b35, D30:h35, a38:a43, b38:b46, D38:h46, q10:v35").ClearContents
End If
ActiveSheet.Protect
Range("a8").Select
End Sub
Was meint ihr dazu?