Worksheet_Change zum ausfüllen von Zellen

Zellen · 2006-02-10T19:28:15+00:00

Hallo und guten Abend, das Wochenende naht und ich möchte meine Idee die ich in der Woche mit mir herum trage, versuchen umzusetzen. A B C D E 1 PLZ Ort Straße Werte Nummer 2 19300 Tuckhude Mittelweg 538,30 AA-14 3 19300 Neuhof Neustädter Str. 2.607,30 AA-14 4 19300 Neuhof Riet'ut 469,72 BB-10 5 19300 Neuhof Schulstr. 1.682,28 AA-14 6 19300 Neuhof Tannenweg 231,20 AA-14 7 19300 Dambeck Amselweg 5.067,50 AA-14 Diagramm - Grafik - Excel Tabellen einfach im Web darstellen Excel Jeanie HTML 3.0 Download Folgendes möchte ich in der oben genannten Tabelle erreichen. Wenn ich in der Spalte "Nummer" die Nummer ändere, sollte automatisch alle anderen Nummern die zu der PLZ und Ort gehören umgewandelt werden. Also, ich habe oben im Ort 19300 Neuhof die Nummer "BB-10" gesetzt, nun sollen alle Zeilen die die gleiche PLZ und Ort besitzen die gleiche Nummer erhalten. Vorher möchte ich noch eine Abfrage erhalten, ob es wirklich sein soll oder nicht, da mit unter vereinzelt nur Straßen eine Nummer erhalten. Den Code für die Abfrage traue ich mir zurnächst selber zu. Läßt sich meine Idee so ohne weiteres umsetzen? Wenn ja, wie müßte die Ereignisprozedur geschrieben werden? Gruß Korl

Hallo Korl,
viel schneller gehts IMHO nicht mehr:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range
Dim strZuÄndern As String
Dim lngOldCalculation As Long
Dim intOffset As Integer
Dim intOrt As Integer
Dim strStart As String
Const strNummern = "E7:E15" 'Bereich mit den Nummern
Const strSuchen = "B7:B15" 'Bereich der Ortsnamen

intOffset = Range(strNummern).Column - Range(strSuchen).Column
intOrt = Range(strSuchen).Column
If Intersect(Range(strNummern), Target) Is Nothing Then Exit Sub
If MsgBox("Willst Du oder nicht", vbYesNo, "Frage") = vbNo Then Exit Sub
lngOldCalculation = Application.Calculation
strZuÄndern = Cells(Target.Row, intOrt - 1) & "|" & Cells(Target.Row, intOrt)
On Error GoTo NixDa
With Application
  .EnableEvents = False: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Set rngZelle = Range(strSuchen).Find(What:=Target.Offset(0, -intOffset))
If Not rngZelle Is Nothing Then
    strStart = rngZelle.Address
    Do
        If rngZelle.Offset(0, -1) & "|" & rngZelle = strZuÄndern Then
            rngZelle.Offset(0, intOffset) = Target
        End If
        Set rngZelle = Range(strSuchen).FindNext(rngZelle)
    Loop Until rngZelle.Address = strStart
End If

NixDa:
With Application
  .EnableEvents = True: .ScreenUpdating = True:  .Calculation = lngOldCalculation
End With
End Sub

Gruß- Micha
PS: Rückmeldung wäre nett.

Hallo Nils und Micha,
ich habe mal die Abschaltapplicationen von Nils in Michas Code eingebaut, der jetzt so aussieht:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngZelle As Range
Dim strZuÄndern As String, strFrage As String
Dim lngOldCalculation As Long
Const strNummern = "E2:E5001" 'Bereich mit den Nummern
Const intPLZ = 1 'Spalte der PLZ, Ortsnamensspalte wird rechts daneben angenommen
Application.ScreenUpdating = False
If Intersect(Range(strNummern), Target) Is Nothing Then Exit Sub
strZuÄndern = Cells(Target.Row, intPLZ) & "|" & Cells(Target.Row, intPLZ + 1)
strFrage = MsgBox("Willst Du den ganzen Ort ändern? ", vbYesNo, "Frage")
If strFrage = vbYes Then
On Error GoTo NixDa
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Application.EnableEvents = False
For Each rngZelle In Range(strNummern)
If Cells(rngZelle.Row, intPLZ) & "|" & Cells(rngZelle.Row, intPLZ + 1) = strZuÄndern Then
rngZelle = Target
End If
Next rngZelle
Else
Exit Sub
End If
'Application.ScreenUpdating = True
NixDa:
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlAutomatic  'lngOldCalculation
End With
'Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub

In diesem Zustand läuft er schon sehr flott. Er wäre so schon gebrauchsfähig. ;-)
Meine offene Frage wäre noch, kann ich die Abfrage in der Ereignisprozedur unterbinden, wenn ich die Daten durch kopieren, in diese Tabelle einfüge?
Gruß Korl
PS: übrigens ist es nicht wer weiß wie eilig, freue mich schon sehr, dass ich überhaupt so weit gekommen bin.

Worksheet_Change zum ausfüllen von Zellen

Forumthread: Worksheet_Change zum ausfüllen von Zellen

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Worksheet_Change zum ausfüllen von Zellen

Forumthread: Worksheet_Change zum ausfüllen von Zellen

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread