Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabelle nach Wörtern durchsuchen und Kommentar ein

Tabelle nach Wörtern durchsuchen und Kommentar ein
11.03.2013 14:50:08
Steffen
Hallo,
ich habe ein Problem beim Programmieren von VBA in Excel.
Ich suche eine Möglichkeit ein Excel Datei mit einer Referenz-Excel-Tabelle (in der bestimmte Wörter stehen) zu vergleichen und die gefundenen Wöter in der durchsuchten Datei mit Kommentaren, welche ebenfalls in der Referenztabelle neben dem jeweiligen Wort stehen, zu versehen.
Aktuell habe ich einen Code der Wörter aus einer Referenzdatei sucht und diese ersetzt. Jedoch soll es nicht ersetzt werden sondern in einer Extra Spalte der Kommentar eingefügt werden.
Der Code sieht zur Zeit so aus.

Option Explicit
Const wdreplaceAll = 2
Dim blnTMP As Boolean
Public Sub Main_1()
' Dimensionieren der Variablen
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim varFiles As Variant
Dim intFiles As Integer
Dim lngLastRow As Long
Dim strDatei As String
Dim objApp As Object
Dim lngCalc As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
ChDrive ("C")
ChDir (ThisWorkbook.Path)
' Dateiauswahl - MEHRERE Dateien können ausgewählt werden
' Mit STRG / CTRL bzw. mit der Umschalttaste
varFiles = Application.GetOpenFilename( _
FileFilter:="Excel-Dateien (*.xlsx*), *.xlsx*", _
MultiSelect:=True)
If Not VarType(varFiles) = vbBoolean Then
' Die Excelapplikation wird ruhig gestellt
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objApp = OffApp("Excel")
' Excel nicht sichtbar
Set objApp = OffApp("Excel", False)
If Not objApp Is Nothing Then
' Tabellenblattname gegebenenfalls anpassen
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
' Mach das für alle im Dialog ausgewählten Dateien
For intFiles = 1 To UBound(varFiles)
' Exceldokument öffnen
Set objDocument = objApp.Document.Open _
(varFiles(intFiles))
' Schleife von Zeile 2 in Spalte B bis zum Ende von Spalte B
For lngLastRow = 2 To wksSheet.Cells _
(wksSheet.Rows.Count, 2).End(xlUp).Row
With objDocument.Content.Find
' Diesen Text suchen
.Text = wksSheet.Cells(lngLastRow, 2).Value
                        ' Mit diesem Text austauschen / ersetzen
.Replacement.Text = wksSheet.Cells(lngLastRow, 4).Value
' Tu es!
.Execute Replace:=wdreplaceAll

End With
Next lngLastRow
' Worddokument MIT speichern schliessen
objDocument.Close True
' Objektvariable leeren
Set objDocument = Nothing
' Die nächste ausgewählte Datei
Next intFiles
Else
MsgBox "Application not installed!"
End If
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
Set wksSheet = Nothing
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function

Das Fett gedruckt soll die Wörter nicht ersetzen sondern Kommentare aus der Referenztabelle angeben.Ist das möglich?
Ebenso bekomme ich beim testen des Code einen Fehler 438 angezeigt. Woran kann das liegen?
Vielen Dank.
Liebe Grüße
Steffen

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Da musst du halt die entsprd PgmZeilen ...
11.03.2013 19:49:08
Luc:-?
…und die zugehörigen Kommentare (2 relevante Zeilen ab .Text = wksSheet.Cells(lngLastRow, 2).Value ) durch .AddComment … (usw → in VBE-Hilfe nachlesen!) ersetzen, Steffen.
Allerdings kann ich dir nicht sagen, ob es dafür auch ein Execute gibt. Aber das könnte ggf mit .FindNext umgangen wdn. Wäre natürlich besser, der OriginalPgmierer würde das anpassen.
Gruß Luc :-?
Anzeige

335 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige