Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

VBA Script umbauen - replace

Betrifft: VBA Script umbauen - replace von: Philip
Geschrieben am: 15.09.2020 13:44:37

Moin Zusammen,


ihr müsst bitte mir einmal Licht ans Fahrrad machen, ich bin etwas aufgeschmissen. Wir haben ein Script gebaut, welches in der Spalte 20 Werte überprüft und aus einer Mapping Tabelle ersetzt:

Sub SuchenErsetzen2()

Dim arName3 As Variant
Dim arName4 As Variant
Dim ii As Long
Dim lngSpalte2 As Long

With Sheets("Do-Not-Edit")
arName3 = .Range("F2:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
arName4 = .Range("H2:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With

On Error Resume Next
lngSpalte2 = Columns(20).Column
On Error GoTo Ende


With Sheets("NSC")
If lngSpalte2 > 0 Then
For ii = LBound(arName3) To UBound(arName3)
    .Columns(lngSpalte2).Replace arName3(ii, 1), arName4(ii, 1), xlWhole
Next
End If
End With

Exit Sub

Jetzt möchte ich aber nicht, dass er den Namen3 gegen den Namen4 ersetzt. Er soll stattdessen in Spalte 47 den Wert arName4 eintragen.


Hier weiß ich leider nicht wie ich vorgehen soll. Kann mir jemand hier helfen?


Vielen Dank!


VG

Philip

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 14:16:39

Hallo Philip,

teste mal:

Public Sub SuchenErsetzen2()
    
    Dim avntName3 As Variant
    Dim avntName4 As Variant
    Dim ialngIndex As Long
    Dim strFirsAddress As String
    Dim objCell As Range
    
    On Error GoTo Ende
    
    With Worksheets("Do-Not-Edit")
        avntName3 = .Range("F2:F" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
        avntName4 = .Range("H2:H" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
    End With
    
    With Worksheets("NSC")
        For ialngIndex = LBound(avntName3) To UBound(avntName3)
            Set objCell = .Columns(20).Find(What:=avntName3(ialngIndex, 1), _
                LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not objCell Is Nothing Then
                strFirsAddress = objCell.Address
                Do
                    objCell.Offset(0, 27).Value = avntName4(ialngIndex, 1)
                    Set objCell = .Columns(20).FindNext(After:=objCell)
                Loop Until objCell.Address = strFirsAddress
                Set objCell = Nothing
            End If
        Next
    End With
    
    Exit Sub
    Ende:
    '???
End Sub

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 14:21:47

Das funktioniert leider nicht.

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 14:26:51

Moment, er rödelt wie bekloppt, aber es scheint zu funktion ieren.

Er arbeitet aber fast 30 Minuten.

VG
Philip

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 14:31:22

Hallo Philip,

30 Minuten? Du hast meine Antwort erst vor 10 Minuten bekommen. Wie viele Einträge hat den die Spalte A in der Tabelle "Do-Not-Edit"? Sind in dieser Tabelle in der Spalte F leere Zeilen?

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 14:27:12

Hallo Philip,

wie habe ich das zu verstehen. Ich habe deine Frage so verstanden:

Suche in Spalte 20 nach den Einträgen aus dem ersten Array und trage in Spalte 47 die korrespondierenden Werte aus dem zweiten Array ein.

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 14:31:18

Ich melde mich gleich. Glaube im Script stand Zelle 27. Ändere das eben und teste es.

Danke Dir!

Betrifft: AW: VBA Script umbauen - replace
von: max.kaffl@gmx.de
Geschrieben am: 15.09.2020 14:33:21

Hallo Philip,

nicht Zelle 27 sondern 27 Spalten von Spalte 20 entfernt. Das bedeutet nämlich Offset.

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 14:35:51

Danke. Es funktionert :))))

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 15:19:52

Eine kurze Frage habe ich noch.
Die Laufzeit des Skriptes ist ca. 20 Sekunden. Wenn ich das gleiche auf eine andere Spalte mache und nach anderen Kriterien Filter, dann läuft das binnen 2 Sekunden für 1000 Zeilen. Kann man das so begrenzen, dass er nur noch 1000 Zeilen sich ansieht in der Schleife?

Wäre das mit einer Eingrenzung der maximalen Werteanzahl für den Zähler möglich?

Vielen Dank!

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 15:32:49

Hallo Philip,

dann muss ich nochmal fragen, befinden sich in Tabelle "Do-Not-Edit" in Spalte F leere Zellen? Das würde nämlich die Laufzeit erklären. Dann findet die Find-Methode nämlich alle leeren Zeilen in Spalte 20 und das sind bei 1.000 Datenzeilen 1.047.576 Zellen.

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 15:39:44

Nein leider nicht bewusst. Evtl. irgendwo dazwischen, sichtbar erstmal nicht.

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 15:39:47

Nein leider nicht bewusst. Evtl. irgendwo dazwischen, sichtbar erstmal nicht.

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 15:41:55

Habe noch einmal die Spalten neu angelegt - keine Veränderung.

Bin etwas ratlos.

VG
Philip

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 15:45:41

Hallo Philip,

dann weiß ich auch nicht woran es liegt. Versuch mal den Suchbereich der Find-Methode einzugrenzen:

Option Explicit

Public Sub SuchenErsetzen2()
    
    Dim avntName3 As Variant
    Dim avntName4 As Variant
    Dim ialngIndex As Long
    Dim strFirsAddress As String
    Dim objCell As Range
    
    On Error GoTo Ende
    
    With Worksheets("Do-Not-Edit")
        avntName3 = .Range("F2:F" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
        avntName4 = .Range("H2:H" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
    End With
    
    With Worksheets("NSC")
        With .Range(.Cells(1, 20), .Cells(.Rows.Count, 20).End(xlUp))
            For ialngIndex = LBound(avntName3) To UBound(avntName3)
                Set objCell = .Find(What:=avntName3(ialngIndex, 1), _
                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not objCell Is Nothing Then
                    strFirsAddress = objCell.Address
                    Do
                        objCell.Offset(0, 27).Value = avntName4(ialngIndex, 1)
                        Set objCell = .FindNext(After:=objCell)
                    Loop Until objCell.Address = strFirsAddress
                    Set objCell = Nothing
                End If
            Next
        End With
    End With
    
    Exit Sub
    Ende:
    '???
End Sub

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 15:50:59

Funktioniert, bester Mann!

Vielen vielen Dank!

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 16:37:20

Eine allerletzte Frage habe ich noch:

Wenn ich nun noch prüfen möchte, dass in Spalte 20 ein Wert steht, der nicht in unter F2:F steht, dann soll er eine Fehlermeldung bringen, dass in Zeile XY ein Fehler ist. Wenn gar nichts drin steht, dann ist das zu ignorieren.

Vielen Dank :*

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 17:19:32

Hallo Philip,

teste mal:

Option Explicit

Public Sub SuchenErsetzen2()
    
    Dim avntName3 As Variant
    Dim avntName4 As Variant
    Dim avntValues As Variant
    Dim ialngIndex As Long
    Dim strFirsAddress As String
    Dim objCell As Range
    Dim objDictionary As Object
    
    On Error GoTo Ende
    
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    
    With Worksheets("Do-Not-Edit")
        avntName3 = .Range("F2:F" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
        avntName4 = .Range("H2:H" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
    End With
    
    With Worksheets("NSC")
        With .Range(.Cells(1, 20), .Cells(.Rows.Count, 20).End(xlUp))
            For ialngIndex = LBound(avntName3) To UBound(avntName3)
                objDictionary.Item(Key:=avntName3(ialngIndex, 1)) = vbNullString
                Set objCell = .Find(What:=avntName3(ialngIndex, 1), _
                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not objCell Is Nothing Then
                    strFirsAddress = objCell.Address
                    Do
                        objCell.Offset(0, 27).Value = avntName4(ialngIndex, 1)
                        Set objCell = .FindNext(After:=objCell)
                    Loop Until objCell.Address = strFirsAddress
                    Set objCell = Nothing
                End If
            Next
            avntValues = .Value
            For ialngIndex = LBound(avntValues) To UBound(avntValues)
                If Not objDictionary.Exists(Key:=avntValues(ialngIndex, 1)) Then _
                    Call MsgBox("Fehler in Zeile " & CStr(ialngIndex), vbCritical, "Falsche Eintrag")
            Next
            Set objDictionary = Nothing
        End With
    End With
    
    Exit Sub
    Ende:
    '???
End Sub

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 17:22:36

Ooooooops,

die leeren Zellen ausschließen habe ich vergessen.

Option Explicit

Public Sub SuchenErsetzen2()
    
    Dim avntName3 As Variant
    Dim avntName4 As Variant
    Dim avntValues As Variant
    Dim ialngIndex As Long
    Dim strFirsAddress As String
    Dim objCell As Range
    Dim objDictionary As Object
    
    On Error GoTo Ende
    
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    
    With Worksheets("Do-Not-Edit")
        avntName3 = .Range("F2:F" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
        avntName4 = .Range("H2:H" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
    End With
    
    With Worksheets("NSC")
        With .Range(.Cells(1, 20), .Cells(.Rows.Count, 20).End(xlUp))
            For ialngIndex = LBound(avntName3) To UBound(avntName3)
                objDictionary.Item(Key:=avntName3(ialngIndex, 1)) = vbNullString
                Set objCell = .Find(What:=avntName3(ialngIndex, 1), _
                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not objCell Is Nothing Then
                    strFirsAddress = objCell.Address
                    Do
                        objCell.Offset(0, 27).Value = avntName4(ialngIndex, 1)
                        Set objCell = .FindNext(After:=objCell)
                    Loop Until objCell.Address = strFirsAddress
                    Set objCell = Nothing
                End If
            Next
            avntValues = .Value
            For ialngIndex = LBound(avntValues) To UBound(avntValues)
                If Not IsEmpty(avntValues(ialngIndex, 1)) Then _
                    If Not objDictionary.Exists(Key:=avntValues(ialngIndex, 1)) Then _
                    Call MsgBox("Fehler in Zeile " & CStr(ialngIndex), vbCritical, "Falsche Eintrag")
            Next
            Set objDictionary = Nothing
        End With
    End With
    
    Exit Sub
    Ende:
    '???
End Sub

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 17:31:25

Vielen Dank. Aktuell sagt er immer, dass er in Zeile 1 einen Fehler hat. Er muss praktisch ja bei 2 starten, da 1 die Überschrift ist. Trage ich in Zeile 1 einen richtigen Wert ein, spukt er es aus.

Betrifft: AW: VBA Script umbauen - replace
von: Nepumuk
Geschrieben am: 15.09.2020 17:35:41

Hallo Philip,

das kommt wenn man wichtige Informationen zurückhält.

Option Explicit

Public Sub SuchenErsetzen2()
    
    Dim avntName3 As Variant
    Dim avntName4 As Variant
    Dim avntValues As Variant
    Dim ialngIndex As Long
    Dim strFirsAddress As String
    Dim objCell As Range
    Dim objDictionary As Object
    
    On Error GoTo Ende
    
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    
    With Worksheets("Do-Not-Edit")
        avntName3 = .Range("F2:F" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
        avntName4 = .Range("H2:H" & CStr(.Cells(.Rows.Count, 1).End(xlUp).Row)).Value
    End With
    
    With Worksheets("NSC")
        With .Range(.Cells(2, 20), .Cells(.Rows.Count, 20).End(xlUp))
            For ialngIndex = LBound(avntName3) To UBound(avntName3)
                objDictionary.Item(Key:=avntName3(ialngIndex, 1)) = vbNullString
                Set objCell = .Find(What:=avntName3(ialngIndex, 1), _
                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                If Not objCell Is Nothing Then
                    strFirsAddress = objCell.Address
                    Do
                        objCell.Offset(0, 27).Value = avntName4(ialngIndex, 1)
                        Set objCell = .FindNext(After:=objCell)
                    Loop Until objCell.Address = strFirsAddress
                    Set objCell = Nothing
                End If
            Next
            avntValues = .Value
            For ialngIndex = LBound(avntValues) To UBound(avntValues)
                If Not IsEmpty(avntValues(ialngIndex, 1)) Then _
                    If Not objDictionary.Exists(Key:=avntValues(ialngIndex, 1)) Then _
                    Call MsgBox("Fehler in Zeile " & CStr(ialngIndex + 1), vbCritical, "Falsche Eintrag")
            Next
            Set objDictionary = Nothing
        End With
    End With
    
    Exit Sub
    Ende:
    '???
End Sub

Gruß
Nepumuk

Betrifft: AW: VBA Script umbauen - replace
von: Philip
Geschrieben am: 15.09.2020 17:40:37

Hast du vollkommen Recht. Ich bin sehr beeindruckt von deiner Hilfsbereitschaft. Wahnsinnig.
Der absolute Hammer, funktioniert prima!

Hab einen schönen Abend!

Beiträge aus dem Excel-Forum zum Thema "VBA Script umbauen - replace"