Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1164to1168
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten in Tabellenblatt 2 ablegen und archivieren

Daten in Tabellenblatt 2 ablegen und archivieren
Jasper
Hallo Excel-Experten.
Folgendes Problem…
In Tabellenblatt 1 sind:
In (A2-A41) ca. 40 Namen , in (B) mit Überschrift das Datum(B1) immer Sonntags die Wettkampfleistungen (B2-B41) (Minuten : in blau oder Weiten,in rot oder Runden,in grün)
Wunsch:
Sobald über Stg & L = Makro(Tabelle1) -aktuelle Einträge löschen- die Einträge gelöscht werden, sollen die Zeiten aus (B2-B41) mit entsprechender Farbe und Beachtung der Namen auf das Tabellenblatt 2 übertragen werden.
In Tabellenblatt 2 warten in (A2-A60) ca. 60 Namen( alte, aktuelle und im laufenden Jahr neue Namen).
In B1,C1… bis CO1 wartet das Datum.(fürs ganze Jahr bekannt)
Hier (Tblt 2) sollte dann mit jedem neuen Datum(Tblt 1, B1) die passende Spalte (B2-B60,C2-C60….CO2-CO60) gefunden werden um dort bei entsprechendem Namen(A2-A60) die Zeiten(B2-B60, dann C2-C60, dann D2-D60) mit Farbe zuzuordnen.
Ist ein Name ohne Wettkampfdaten, so bleibt das Feld leer.
Wer kann dabei helfen ?
Großes Dankeschön im Voraus.
Jasper
AW: Daten in Tabellenblatt 2 ablegen und archivieren
25.06.2010 15:54:33
Jasper
Hier eine Beispielwunschdatei.
https://www.herber.de/bbs/user/70275.xlsm
mit Button zum Archiv.
1000 Dank im Voraus.
Jasper
AW: Daten in Tabellenblatt 2 ablegen und archivieren
26.06.2010 13:44:35
fcs
Moin Jasper,
mit folgenden Anpassungen und Ergänzungen werden vor dem löschen die Daten ins Archiv übertragen.
Vor bzw. während des Übertragens werden mehrere Prüfungen durchgeführt. Je nach Ergebnis und getroffener Auswahl werden die Daten im Eingabeblatt dann nicht gelöscht.
Gruß
Franz
Sub loeschen()
Dim sh1 As Object
Dim rng1, rng2  As Range
If Archivieren = False Then GoTo Beenden
Set sh1 = ThisWorkbook.Sheets("Eingaben")
Set rng1 = sh1.Range("b2:b6"): rng1.ClearContents
Set rng2 = sh1.Range("B1"): rng2.ClearContents
Beenden:
End Sub
Function Archivieren() As Boolean
Dim Zeile As Long
Dim wksEingabe As Worksheet, wksArchiv As Worksheet
Dim Zelle As Range, SpalteA As Long, ZeileA As Long
Dim sName As String, vDatum As Variant
Archivieren = True
Set wksArchiv = Worksheets("Archiv")
Set wksEingabe = Worksheets("Eingaben")
vDatum = wksEingabe.Cells(1, 2)
'Datum im Archiv suchen
With wksArchiv
For SpalteA = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, SpalteA) = vDatum Then Exit For
Next
If SpalteA > .Cells(1, .Columns.Count).End(xlToLeft).Column Then
MsgBox "Datum """ & vDatum & """ fehlt im Blatt ""Archiv"""
Archivieren = False
GoTo Beenden
End If
End With
If wksArchiv.Cells(wksArchiv.Rows.Count, SpalteA).End(xlUp).Row > 1 Then
If MsgBox("Im Archiv stehen für """ & vDatum & """ schon Daten" _
& vbNewLine & vbNewLine & "Daten überschreiben?", _
vbQuestion + vbYesNo + vbDefaultButton2, "Daten ins Archiv") = vbNo Then
Archivieren = False
GoTo Beenden
Else
'Für Tag vorhandenen Daten löschen
With wksArchiv
.Range(.Cells(2, SpalteA), _
.Cells(.Rows.Count, SpalteA).End(xlUp)).Clear
End With
End If
End If
'Daten ins Archiv übertragen
For Zeile = 2 To wksEingabe.Cells(wksEingabe.Rows.Count, 1).End(xlUp).Row
sName = wksEingabe.Cells(Zeile, 1)
Set Zelle = wksArchiv.Columns(1).Find(what:=sName, LookIn:=xlValues, _
lookat:=xlWhole)
If Zelle Is Nothing Then
If MsgBox("Name """ & sName & """ fehlt im Blatt """ & wksArchiv.Name & """" _
& vbNewLine & vbNewLine & "Namen in Liste ergänzen?", _
vbQuestion + vbYesNo, "Daten ins Archiv") = vbYes Then
'Neuen Namen einfügen
ZeileA = wksArchiv.Cells(wksArchiv.Rows.Count, 1).End(xlUp).Row + 1
wksArchiv.Cells(ZeileA, 1) = sName
wksEingabe.Cells(Zeile, 2).Copy wksArchiv.Cells(ZeileA, SpalteA)
Else
Archivieren = False
End If
Else
ZeileA = Zelle.Row
wksEingabe.Cells(Zeile, 2).Copy wksArchiv.Cells(ZeileA, SpalteA)
End If
Next
Beenden:
End Function

Anzeige
AW: Daten in Tabellenblatt 2 ablegen und archivieren
26.06.2010 14:24:21
Jasper
Hallo Franz,
es funktioniert fast perfekt.
Leider sind in der Spalte B nicht „Einträge“ sondern das Ergebnis aus Formeln und Berechnungen. Deine Liste zeigt somit immer „0“ an... ?
Danke auch für die eingebauten „Fehlermeldungen“ !!!!
Wunsch wäre auch noch, da die Liste zwischenzeitlich gewachsen ist, dass nicht ab (Eingabe)B2 ins Archiv verschoben wird, sondern ab (Eingabe)CW5 bis CW50
Kann man das noch ändern?
Im Archiv kommt aber alles Tipp Topp an!
Das erste öffnen und starten ist fast immer besser als Weihnachten(…)
Gruß Jasper
AW: Daten in Tabellenblatt 2 ablegen und archivieren
26.06.2010 14:42:57
Jasper
Habe "Frage noch offen" vergessen.
Gruß Jasper
Anzeige
AW: Daten in Tabellenblatt 2 ablegen und archivieren
26.06.2010 15:18:57
fcs
Hallo Jasper,
ist halt immer nicht so gut, wenn eine Beispieldatei nur 95% der erforderlichen Infos enthält.
Der Kopiervorgang und die Spalten/Zeilennummern müssen dann halt angepasst werden.
Ich hab für die Spalten/Zeilen im Eingabeblatt jetzt Konstanten festgelegt, die du ggf. anpassen muss.
Gruß
Franz
Function Archivieren() As Boolean
Dim Zeile As Long
Dim wksEingabe As Worksheet, wksArchiv As Worksheet
Dim Zelle As Range, SpalteA As Long, ZeileA As Long
Dim sName As String, vDatum As Variant
Const SpalteNamen As Long = 1 'Spalte mit Namen im Eingabeblatt
Const Zeile1 As Long = 5      '1. Zeile mit Name im Eingabeblatt
Const SpalteWert As Long = 101 'Spalte mit Werten im Eingabeblatt - Spalte CW
Archivieren = True
Set wksArchiv = Worksheets("Archiv")
Set wksEingabe = Worksheets("Eingaben")
'Datum aus Zelle B1 einlesen
vDatum = wksEingabe.Range("B1")
'Datum im Archiv suchen
With wksArchiv
For SpalteA = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, SpalteA) = vDatum Then Exit For
Next
If SpalteA > .Cells(1, .Columns.Count).End(xlToLeft).Column Then
MsgBox "Datum """ & vDatum & """ fehlt im Blatt ""Archiv"""
Archivieren = False
GoTo Beenden
End If
End With
If wksArchiv.Cells(wksArchiv.Rows.Count, SpalteA).End(xlUp).Row > 1 Then
If MsgBox("Im Archiv stehen für """ & vDatum & """ schon Daten" _
& vbNewLine & vbNewLine & "Daten überschreiben?", _
vbQuestion + vbYesNo + vbDefaultButton2, "Daten ins Archiv") = vbNo Then
Archivieren = False
GoTo Beenden
Else
'Für Tag vorhandenen Daten löschen
With wksArchiv
.Range(.Cells(2, SpalteA), _
.Cells(.Rows.Count, SpalteA).End(xlUp)).Clear
End With
End If
End If
'Daten ins Archiv übertragen
'Namen im Eingabeblatt abarbeiten
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Zeile = Zeile1 To wksEingabe.Cells(wksEingabe.Rows.Count, SpalteNamen).End(xlUp).Row
sName = wksEingabe.Cells(Zeile, SpalteNamen)
'Namen in Spalte 1 des Archivs suchen
Set Zelle = wksArchiv.Columns(1).Find(what:=sName, LookIn:=xlValues, _
lookat:=xlWhole)
If Zelle Is Nothing Then
If MsgBox("Name """ & sName & """ fehlt im Blatt """ & wksArchiv.Name & """" _
& vbNewLine & vbNewLine & "Namen in Liste ergänzen?", _
vbQuestion + vbYesNo, "Daten ins Archiv") = vbYes Then
'Neuen Namen einfügen
ZeileA = wksArchiv.Cells(wksArchiv.Rows.Count, 1).End(xlUp).Row + 1
wksArchiv.Cells(ZeileA, 1) = sName
'Format und Wert aus Eingabezelle in Datumsspalte kopieren
wksEingabe.Cells(Zeile, SpalteWert).Copy
wksArchiv.Cells(ZeileA, SpalteA).PasteSpecial Paste:=xlPasteFormats
wksArchiv.Cells(ZeileA, SpalteA).PasteSpecial Paste:=xlPasteValues
Else
Archivieren = False
End If
Else
ZeileA = Zelle.Row
'Format und Wert aus Eingabezelle in Datumsspalte kopieren
wksEingabe.Cells(Zeile, SpalteWert).Copy
wksArchiv.Cells(ZeileA, SpalteA).PasteSpecial Paste:=xlPasteFormats
wksArchiv.Cells(ZeileA, SpalteA).PasteSpecial Paste:=xlPasteValues
End If
Next
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Beenden:
End Function

Anzeige
AW: Perfekt nur die Farben ?
26.06.2010 16:09:37
Jasper
Hallo Franz,
entschuldige die zusätzliche Mühe, aber das Ding ist in den letzten Tagen ordentlich gewachsen. Nehme aber den Rat gerne an.
Jetzt läuft alles, nur die Farben werden nicht ins Archiv übernommen. Vermutlich, da sie über „bedingte Formatierung“ entstehen, denn bei neuer manueller Farbauswahl wird diese Farbe übernommen.
Nochmals vielen Dank und ein schönes Wochenende.
Gruß Jasper
AW: Perfekt nur die Farben ?
27.06.2010 11:37:14
fcs
Hallo Jasper,
die Ergebnis-Farbe einer bedingten Zell-Formatierung per VBA zu ermitteln ist extrem kompliziert, da hier ggf. alle möglichen Variationen der bedingten Formate der jeweiligenZelle ausgewertet werden müssen.
Wenn dir die Farben sehr wichtig sind, dann gibt es folgende Möglichkeiten:
A- Im Archiv wird für die Datums-Spalten eine bedingte Formatierung festgelegt.
Ob dies geht hängt davon ab, ob "m", "Runden", "nur Zeitwert" als Teil des Zellinhalts zur Farbfestlegung ausreichen.
B- Die bedingten Farben für das Archiv werden in der VBA-Prozdur neu ermittelt. Das geht einfacher.
Allerdings dürfen beim Übertragen der Werte ins Archiv dann nicht alle Formate der Werte Spalte mit kopiert werden .
Falls du die Anpassung noch möchtest bräuchte ich den aktuellen Stand des Eingabeblatts mit ein paar Beispielzeilen (Namen ggf. anonymisieren!!)
Gruß
Franz
Anzeige
AW: Farben ok, jetzt aber 1004 Laufzeitfehler...
29.06.2010 21:08:53
Jasper
Hallo Franz,
die bedingte Formatierung läuft jetzt auch. Danke für den Tipp. Hier war Teil(a1;1;3) sehr hilfreich, da nur der erste Teil, der zusammengesetzten Zelle ( 4x&) für die Farbe verantwortlich ist.
Jetzt hat sich aber die Fehlermeldung : 1004 „Die ColorINdex-Eigenschaft des Interior-Objektes kann nicht festgelegt werden“ eingeschlichen.(?)
In „Diese Arbeitsmappe“ steht mehrmals für bestimmte Bereiche:
Private Sub Workbook_Open()
Dim lngColor As Long
Dim rng As Range
For Each rng In Range("f5:f54") 'Bereich anpassen 1!
Select Case rng.Value
'Case 0: lngColor = 15
Case "1": lngColor = 36
Case Else: lngColor = 15
End Select
Union(Cells(rng.Row, 32), Cells(rng.Row, 34), Cells(rng.Row, 36), _
Cells(rng.Row, 38), Cells(rng.Row, 40), Cells(rng.Row, 42), Cells(rng.Row, 44), Cells(rng.Row, 46)).Interior.ColorIndex = lngColor
Next
For Each rng In Range("g5:g54") 'Bereich anpassen 2!
Select Case rng.Value
'Case 0: lngColor = 15
Case "1": lngColor = 36
Usw.
Bei Deiner ersten Version wurde diese Fehlermeldung nicht angezeigt.
Alle Versuche meinerseits verlaufen bisher negativ. Kannst Du helfen?
Gruß Jasper
Anzeige
AW: Farben ok, jetzt aber 1004 Laufzeitfehler...
30.06.2010 06:45:50
fcs
Hallo Jasper,
die Prozedur als solche funktioniert. Da muss noch irgendeine andere Ursache vorliegen.
Ich kann dir also nicht sagen wo du ansetzen muss.
Schick mir ggf. die Datei an meine email-Adresse - findest du hier unter Forums-Seiten --> Profile --> Profilliste. Dann kann ich's mal testen.
Gruß
Franz
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige