Worksheet_Change zum ausfüllen von Zellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngZelle As Range Dim strZuÄndern As String Dim lngOldCalculation As Long Const strNummern = "E7:E15" 'Bereich mit den Nummern Const intPLZ = 1 'Spalte der PLZ, Ortsnamensspalte wird rechts daneben angenommen If Intersect(Range(strNummern), Target) Is Nothing Then Exit Sub lngOldCalculation = Application.Calculation strZuÄndern = Cells(Target.Row, intPLZ) & "|" & Cells(Target.Row, intPLZ + 1) On Error GoTo NixDa With Application .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual End With 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 NixDa: With Application .EnableEvents = True .ScreenUpdating = True .Calculation = lngOldCalculation End With End Sub

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.

Beliebteste Forumthreads (12 Monate)

Worksheet_Change zum ausfüllen von Zellen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread