Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
552to556
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
552to556
552to556
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

2 Fragen: 1x Datum einfügen und 1x Makro

2 Fragen: 1x Datum einfügen und 1x Makro
26.01.2005 11:20:28
Jens
Guten Morgen zusammen.
Nachdem ich hier schon ein paar mal Hilfe bekommen habe, bin ich wieder auf euch angewiesen :-)
Mein erstes Problem ist ein Datumsproblem.
Ich habe mehrere Spalten, die 1-2x die Woche neu erstellt werden, bzw. über ein Makro kopiert und eingefügt werden. Oben steht ein Datum drin, welches sich aber auf den jeweiligen Tag automatisch aktualisieren und auch so bleiben soll !!
Ich habe dazu im Archiv folgendes gefunden:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Range("A1") = Date
End Sub

Wobei ich dann "A1" gegen mein Feld ausgetauscht habe. Allerdings wird dann beim Beenden nur das Datum in dem Arbeitsblatt geändert, welches gerade sichtbar ist und nicht in allen Tabellen in dieser Mappe. Was muß ich ändern ?
Das 2. Problem ist ein Makro, so ein ähnliches habe ich auch schon einmal hier bekommen. Ich habe in besagter Mappe, in den Spalten die da bearbeitet werden Werte drin stehen. Jetzt würde ich gern eine Abfrage machen können, die mir als Ergebnis die Zeilen anzeigt, in denen sich die Werte in Spalte G + H in einem Bereich unterscheiden, den ich selber festlegen kann. Als Beispiel: Zeige alle Zeilen, in denen der Unterschied kleiner als 500 ist, oder größer als 1234 (also das sind nur Beispiele für 2 Möglichkeiten). Oder zeige alle Zeilen an, in denen der Unterschied im Minusbereich liegt. Zur Info, im Normalfall ist der Wert in G größer als in H. Die Abfrage soll dann automatisch alle Tabellen in der Mappe durchsuchen.
Ist so etwas möglich ?
Gruß
Jens

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 2 Fragen: 1x Datum einfügen und 1x Makro
Dr.
Ad 1:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
for i=1 to worksheets.count
sheets(i).Range("A1") = Date
next i
End Sub

zu 2
UweD
Hallo
dazu dieses Makro:

Sub bunt()
For Each tb In Sheets
LR = tb.Cells(Rows.Count, 7).End(xlUp).Row 'letzte Zeile der Spalte
Range("G:H").Interior.ColorIndex = 0 'Zurücksetzen
For Z = 1 To LR
'Hier Beispiele für G kleine H oder
'Unterschied < 500
If Cells(Z, 7).Value < Cells(Z, 8) Or _
Abs(Cells(Z, 7).Value - Cells(Z, 8)) < 500 Then
tb.Range(Cells(Z, 7), Cells(Z, 8)).Interior.ColorIndex = 3
End If
Next
Next
End Sub

Anzeige
AW: zu 2
26.01.2005 12:06:23
Jens
@Uwe: Ich habe das jetzt nicht ausprobiert, aber wenn ich das richtig sehe dann ist das fest eingestellt. Ist es möglich die Werte über ein Auswahlfeld variabel selber einzustellen?
@Dr. : Vielen Dank, funktioniert :)
Ergänzung:
UweD
hallo nochmal
mit einer Inputbox gehts.

Sub bunt()
Dim Abw%, LG%, LH%, LR%, Z%
Abw = InputBox("Soll Unterschied zwischen G und B", "Rot färben", 5000)
For Each Tb In Sheets
LG = Tb.Cells(Rows.Count, 7).End(xlUp).Row 'letzte Zeile der Spalte G
LH = Tb.Cells(Rows.Count, 8).End(xlUp).Row 'letzte Zeile der Spalte H
LR = Application.Max(LG, LH) 'Maximum von G und H
Tb.Range("G:H").Interior.ColorIndex = 0 'Farbe raus
For Z = 1 To LR
If Cells(Z, 7).Value Or Cells(Z, 8).Value <> 0 Then ' Zellwert vorhanden?
If Abs(Cells(Z, 7).Value - Cells(Z, 8)) <= Abw Then
Tb.Range(Cells(Z, 7), Cells(Z, 8)).Interior.ColorIndex = 3 'rot
End If
End If
Next
Next
End Sub

Gruß UweD
Anzeige
AW: Ergänzung:
26.01.2005 14:31:02
Jens
Ok, vielleicht hab ich mich ein wenig unklar ausgedrückt .. sorry. Die Auswertung soll nicht auf dem gleichen Blatt passieren, sondern soll in einem neuen Blatt angezeigt werden und zwar die gesamte Zeile. Ich hänge unten mal das andere Makro an, dann wirds vielleicht deutlicher was ich meine. Das Blatt heißt dann z.B. Auswertung2. Außerdem darf der Vergleich in der Spalte erst ab Zeile 4 beginnen, da in den 3 Zeilen da drüber noch überschriften und Datum stehen (hatte ich leider vergessen anzugeben, sorry)
Hier das erste Makro:

Sub Suchen()
Dim rng As Range
Dim wks As Worksheet, ziel As Worksheet
Dim sFirst As String, sFind As String, sCol As String, sTemp As String
Dim arr As Variant
Dim lRow As Long
Set ziel = Sheets("Auswertung")   'Tabelle für die Ergebnisse
Application.ScreenUpdating = False
On Error GoTo ERRORHANDLER
sTemp = InputBox("Bitte geben sie die zu durchsuchende Spalte" & vbLf & _
"und den Suchbegriff getrennt durch Semikolon (;) ein!" & vbLf & vbLf & _
"Beispiel:  ""C;text""", "Suchen")
If sTemp = "" Then Exit Sub
If InStr(1, sTemp, ";") = 0 Then
sFind = sTemp
sCol = "B"
Else
arr = Split(sTemp, ";")
sCol = UCase(Trim(arr(0)))
sFind = Trim(arr(1))
If sCol = "" Then sCol = "B"
If sFind = "" Then Exit Sub
End If
'Daten in der Zieltabelle löschen
ziel.Cells.ClearContents
lRow = 1
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> ziel.Name Then 'Schleife über alle Tabellen
''oder - um auch andere Tabellen auszuschliessen
'If wks.Name <> ziel.Name And wks.Name <> "andereTabelle" Then
Set rng = wks.Columns(sCol).Find(What:=sFind, LookIn:=xlValues, _
LookAt:=xlPart, after:=Columns(sCol).Cells(65536))
If Not rng Is Nothing Then
sFirst = rng.Address
Do
'Komplette Zeile der Fundstellekopieren
rng.EntireRow.Copy ziel.Cells(lRow, 1)
''Nur die Fundstelle kopieren
'ziel.Cells(lRow, 1) = rng
lRow = lRow + 1
Set rng = wks.Columns(sCol).FindNext(rng)
Loop While rng.Address <> sFirst
End If
End If
Next
Application.ScreenUpdating = True
Exit Sub
ERRORHANDLER:
Application.ScreenUpdating = True
MsgBox "Es ist ein Fehler aufgetreten!"
End Sub

Anzeige
AW: Ergänzung:
27.01.2005 08:39:26
Jens
Hmmm ... keine Idee mehr ? Schade

155 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige