AW: Exceltabelle auf bestimmte Wörter prüfen
04.11.2016 12:33:29
UweD
Hallo nochmal
hab dann doch noch mal nachgedacht...
>> Wenn möglich, dann beim Öffnen ein Pop Up in dem der Bearbeiter seinen Namen hinterlege kann, damit man sehe kann, wer aktuell an der Liste arbeitet.
Es wird ein Logbuch angelegt und die Uhrzeit und der Benutzername eingetragen.
>> Wir benötigen dort eine Bearbeitungsfeld, indem die Badworts schon markiert sind und indem wir den Artikeltext dann übersichtlich bearbeiten können.
Dazu hab ich folgendes im Angebot:
- Bei einer Fundstelle wird das Badword (plus einige Zeichen davor und dahinter) in der Box angezeigt.
- Das Wort (meist in der Mitte stehend) kann dort sofort geändert werden.
>> Dann wäre es auch noch klasse, wenn man z.B. die Tabelle kurzzeitig schließt, weil adere Arbeiten gemacht werden müsen, ein Status kommt, indem die noch zu bearbeitenden Badwords angezeigt werden
am Ende des makros wird gefragt ob gespeichert werden soll
- Mittendrin aufhören:
= speichern, und später wieder öffnen.
= Alle vorher bereits getätigten Änderungen sind ja schon weg.
- wurden alle Badwords ersetzt, oder ist keins enthalten, wird die Datei umbenannt (Bereinigt_abc.xlsx)
Option Explicit
Sub Forbidden()
On Error GoTo Fehler
Dim TB, SP As Integer, ZE As Integer, i As Long, LR As Long
Dim Pfad As String, Ext As String, WB
Dim Suchwort As String, Länge As Integer, DLG, C, JaNein
Dim firstAddress As String, AbWo As Integer, TXT As String, TMP As String
Dim Anz As Integer, j As Integer, k As Integer, l As Integer
Dim Vorne As String, Mitte As String, Hinten As String
'* Anpassen*****
Pfad = "C:\Temp\" 'der Pfad, der bei der Dateiauswahl vorgeschlagen wird
Ext = "*.xlsx" ' Dateien dieser Endung werden voreingestellt
SP = 1 'Spalte A Hier sind die Sperreintrage
ZE = 2 'ab Zeile 2 wegen Überschrift
'* Ende Anpassen*****
Application.ScreenUpdating = False
If Not TabellenblattVorhanden("Logbuch") Then
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Logbuch"
ThisWorkbook.Sheets(1).Activate
End If
With ThisWorkbook.Sheets("Logbuch")
LR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(LR, 1) = Format(Now, "DD.MM.YYYY hh:mm:ss")
.Cells(LR, 2) = Environ("Username")
End With
Set TB = ThisWorkbook.Sheets(1)
LR = TB.Cells(TB.Rows.Count, SP).End(xlUp).Row
Set DLG = Application.FileDialog(msoFileDialogFilePicker)
With DLG
.AllowMultiSelect = False
.InitialFileName = Pfad & Ext
.InitialView = msoFileDialogViewDetails
End With
If DLG.Show = True Then
Workbooks.Open Filename:=DLG.SelectedItems(1)
Set WB = ActiveWorkbook
For i = ZE To LR
Suchwort = TB.Cells(i, SP)
If Suchwort <> "" Then
Länge = Len(Suchwort)
Restart:
Set C = Cells.Find(Suchwort, LookIn:=xlValues)
If Not C Is Nothing Then
TXT = C.Text
firstAddress = C.Address
Do
Anz = (Len(TXT) - Len(Replace(TXT, Suchwort, ""))) / Länge
If Anz > 0 Then
For k = 1 To Anz
l = l + 1
AbWo = InStr(TXT, Suchwort)
Vorne = Left(TXT, WorksheetFunction.Max(1, AbWo - 30))
Mitte = Mid(TXT, Len(Vorne) + 1, Länge + 60)
Hinten = Mid(TXT, Len(Vorne) + Len(Mitte) + 1)
Mitte = InputBox("Badword: '" & Suchwort & "' gefunden!" & _
vbLf & vbLf & ".." & Mitte & "..", "Badwords ändern", Mitte)
If Mitte = "" Then
MsgBox "Ohne Änderung beendet"
GoTo Ende
End If
TMP = Vorne & Mitte & Hinten
If TMP <> TXT Then
j = j + 1
TXT = TMP
Else
l = l - 1
End If
Next k
Range(C.Address) = TXT
GoTo Restart
End If
Set C = Cells.FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End If
Next
Ende:
JaNein = MsgBox("Es wurden " & l & " Badwords gefunden" & vbLf & j & _
" davon wurden geändert" & vbLf & vbLf & "Speichern?", vbYesNo, "Datei speichern/schließen")
If JaNein = vbYes Then
WB.Close True
If l - j = 0 Then
Name DLG.SelectedItems(1) As "Bereinigt_" & Dir(DLG.SelectedItems(1))
End If
End If
End If
Err.Clear
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Function TabellenblattVorhanden(ByVal vName As String) As Boolean
Dim sheetSuche As Worksheet
TabellenblattVorhanden = False
For Each sheetSuche In Worksheets
If UCase(sheetSuche.Name) = UCase(vName) Then
TabellenblattVorhanden = True
Exit Function
End If
Next sheetSuche
End Function
War es das jetzt?
https://www.herber.de/bbs/user/109195.xlsm
LG UweD