Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
648to652
648to652
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

automatische einträge erzeugen

Forumthread: automatische einträge erzeugen

automatische einträge erzeugen
07.08.2005 12:38:03
Sören
Mahlzeit liebe leute,
ich habe mal wieder ein kleines problem:
In Zeile 1 werden durch einen benutzer regelmäßig neue standorte eingegeben. wenn ein neuer standort in zeile 1 (bspw. in zelle F1 = DDD) eingegeben wird, sollen automatisch bei allen varianten in der spalte F 100% auftauchen.
Desweiteren sollen alle einträge (Prozentsätze) in der spalte gelöscht werden, wenn man in zeile 1 einen standort-eintrag löscht.
Die umsetzung müsste mit vba passieren, da der benutzer nachträglich die prozentsätze verändert und somit mit excel wenn-dann nicht umsetzbar ist.
Könnt ihr mir helfen?
Gruß
euer,
sören
anhang: upload
https://www.herber.de/bbs/user/25378.xls
Anzeige

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: automatische einträge erzeugen
07.08.2005 12:58:39
Matthias
Hallo Sören,
ins Modul des betr. Tabellenblattes:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lz As Long, i As Long
Dim Ber As Range, z As Range
Set Ber = Intersect(Target, Rows(1))
For Each z In Target
If z.Count = 1 And z.Row = 1 Then
lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536)
If z.Value = "" Then
Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents
Else
For i = 2 To lz
If Cells(i, 1) <> "" Then
Cells(i, z.Column).Value = 1
End If
Next i
End If
End If
Next z
End Sub

Gruß Matthias
Anzeige
AW: automatische einträge erzeugen
07.08.2005 13:08:13
Sören
Hallo matthias,
danke für deine antwort. das ist super, da kann ich was mit anfangen.
habe noch einen kleines update:
gibts noch die möglichkeit die variante zu integrieren, dass man schon vorhandene standortnamen in zeile 1 ändern kann, ohne dass sich die prozentsätze in der entsprechenden spalte ändern?
gruß,
sören
Anzeige
AW: automatische einträge erzeugen
07.08.2005 13:15:10
Matthias
Hallo Sören,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lz As Long, i As Long
Dim Ber As Range, z As Range
Set Ber = Intersect(Target, Rows(1))
Application.EnableEvents = False
For Each z In Target
lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536)
If z.Value = "" Then
Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents
Else
If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then
For i = 2 To lz
If Cells(i, 1) <> "" Then
Cells(i, z.Column).Value = 1
End If
Next i
End If
End If
Next z
Application.EnableEvents = True
End Sub

(Wurde auch sonst noch ein wenig verbessert.)
Gruß Matthias
Anzeige
AW: automatische einträge erzeugen - Korrektur
07.08.2005 13:22:06
Matthias
Hallo Sören,
damit bei Änderung in A1 oder B1 nichts "passiert", ändere die Zeile noch ab:

Set Ber = Intersect(Target, Range("C1:IV1"))

Gruß Matthias
AW: automatische einträge erzeugen - Korrektur
07.08.2005 13:41:38
Matthias
Hallo Sören,
bei VBA nein fallen dir die Fehler vielleicht nicht auf, hier nochmal die hoffentlich letzte Version:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lz As Long, i As Long
Dim Ber As Range, z As Range
Set Ber = Intersect(Target, Range("C1:IV1"))
If Ber Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each z In Ber
lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536)
If z.Value = "" Then
Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents
Else
If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then
For i = 2 To lz
If Cells(i, 1) <> "" Then
Cells(i, z.Column).Value = 1
End If
Next i
End If
End If
Next z
Application.EnableEvents = True
End Sub

Ich bin heute irgendwie neben der Kappe...
Gruß Matthias
Anzeige
AW: automatische einträge erzeugen - Korrektur
07.08.2005 15:54:30
Sören
hi matthias,
das ist total genial! ich danke dir vielmals für deine mühe - echt klasse!
genau so solls sein. jetzt kann ich das weiter einbauen.
dir noch nen schönen sonntag.
beste grüße,
sören
AW: automatische einträge erzeugen - Korrektur
07.08.2005 16:36:13
Sören
hi matthias,
nur nochmal ne kurze frage:
hast du vielleicht nochmal zeit und lust, deinen code kurz zu kommentieren?
hab noch nicht alle methoden voll und ganz begriffen.
wäre echt super.
gruß, sören
Anzeige
AW: automatische einträge erzeugen - Korrektur
07.08.2005 17:11:37
Matthias
Hallo Sören,
Also, mal sehen:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lz As Long, i As Long
Dim Ber As Range, z As Range
' Ber wird als Schnittmenge aus den geänderten Zellen und C1:IV1 gesetzt:
Set Ber = Intersect(Target, Range("C1:IV1"))
' Wenn in C1:IV1 nichts geändert wurde, dann fertig
If Ber Is Nothing Then Exit Sub
' die Ereignisprozeduren werden abgeschaltet (damit in folgenden Befehlen, die eine
' Zelländerung bewirken, die Prozedur nicht erneut aufgerufen wird:
Application.EnableEvents = False
' Für jede Zelle im Bereich (also alle in Zeile 1 geänderten Zellen):
For Each z In Ber
'lz ist die Zeilennummer der letzten beschriebenen Zelle in Spalte A:
lz = IIf(Cells(Rows.Count, 1) = "", Cells(Rows.Count, 1).End(xlUp).Row, 65536)
'Wenn ein Eintrag gelöscht wurde:
If z.Value = "" Then
'lösche Spalte ab Zeile 2
Range(Cells(2, z.Column), Cells(lz, z.Column)).ClearContents
'sonst:
Else
'Wenn in der Spalte höchstens 1 Wert steht (bei neuer Spalte)
' (VBA-Version von ANZAHL2()
If WorksheetFunction.CountA(z.EntireColumn) <= 1 Then
'Schreibe in jede Zeile, in der in Spalte A etwas steht, eine 1 (=100%)
For i = 2 To lz
If Cells(i, 1) <> "" Then
Cells(i, z.Column).Value = 1
End If
Next i
End If
End If
Next z
'Ereignisprozeduren wieder aktivieren (wichtig!)
Application.EnableEvents = True
End Sub

Ich hoffe, das hat weitergeholfen.
Gruß Matthias
Anzeige
super - vielen vielen dank
07.08.2005 18:53:58
Sören
gruß,
sören

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige