Problem mit VLookup
01.10.2019 16:53:46
Marvin
Ziel ist es eine große Menge an .pdf Dateien auszulesen und umzubennen.
In jeder pdf ist eine Partnernummer, mit der die Datei benannt werden soll.
Dies funktioniert soweit gut.
Zusätzlich soll mit der ermittelten Partnernummer ein VLookup durchgeführt werden.
Das Ergebnis des VLookup (eine Clusterung) soll im Dateinamen vor der Partnernummer stehen, sodass die Dateien letztendlich sortiert abliegen und individuell zugeordnet werden können.
Probleme macht der VLookup.
Cluster = Application.WorksheetFunction.VLookup(SK, Matrix, 2, False)
Diesen habe ich versucht an meine Bedürfnisse anzupassen.
Code ist entsprechend auskommentiert:
Option Explicit
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, beleibt es das auch
Dim blnTMP As Boolean
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 20.05.2019
' Purpose : Aus PDF-Dateien etwas auslesen - Dokumente danach umbenennen
' Note : Funktioniert erst ab Word 2013!!!!!!!!!!
Public Sub Main()
' Dimensionieren der Variablen
Dim objDocument As Object
Dim strTrenn() As String
Dim strDatei As String
Dim strTMP2 As String
Dim strTMP1 As String
Dim strTMP As String
Dim objFSO As Object
Dim objDir As Object
Dim strDir As String
Dim objApp As Object
Dim lngCalc As Long
Dim lngTMP As Long
Dim lngRef As Long
Dim SK As Variant
Dim Cluster As Variant
Dim wksAktiv As Worksheet
Dim Matrix As Range
Set wksAktiv = ActiveSheet
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
lngRef = Application.ReferenceStyle
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Wenn Du einen Ordnerauswahldialog möchtest
'Set objShell = CreateObject("Shell.Application")
'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
'strDir = varDir.Self.Path
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
'strDir = "C:\Temp\Los\" ' Fester Pfad
strDir = IIf(Right(strDir, 1) "\", strDir & "\", strDir)
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
strDatei = Dir$(strDir & "*.pdf", vbDirectory)
Do While strDatei ""
' Word- Pdf-Dokument öffnen - ab Word 2013!!!!!
Set objDocument = objApp.Documents.Open _
(strDir & strDatei)
' Text an Leerzeichen trennen/aufsplitten
strTrenn = Split(objDocument.Range, " ")
' Schleife über das Array von Anfang bis Ende
For lngTMP = LBound(strTrenn) To UBound(strTrenn)
' Wenn das Wort Rechnung gefunden wird...
If strTrenn(lngTMP) Like "*Partnernumm*" Then
' ... schreibe den nächsten Wert in Variable strTMP
strTMP = Trim(strTrenn(lngTMP + 1))
' Oder wenn das Wort Kunde gefunden wird...
ElseIf strTrenn(lngTMP) Like "*Patnernumm*" Then
' ... schreibe den nächsten Wert in Variable strTMP1
strTMP1 = Trim(strTrenn(lngTMP + 1))
ElseIf strTrenn(lngTMP) Like "*Händlernumm*" Then
' ... schreibe den nächsten Wert in Variable strTMP1
strTMP2 = Trim(strTrenn(lngTMP + 1))
End If
Next lngTMP
' Word- Pdf-Dokument ohne speichern schlissen
objDocument.Close False
'Die Partnernummer einer Variablen (für das VLookup Surchkriterium) zuweisen
If strTMP "" Then
SK = strTMP
ElseIf strTMP1 "" Then
SK = strTMP1
ElseIf strTMP2 "" Then
SK = strTMP2
End If
'Matrix definieren in der ein Cluster zugeordnet wird
Set Matrix = wksAktiv.Range("C17:D20")
wksAktiv.Range("A1").Value = SK
Cluster = Application.WorksheetFunction.VLookup(SK, Matrix, 2, False)
'Cluster = wksAktiv.Range("A2").Value
' Datei umbenennen mit Datum und Zeit am Ende
Name strDir & strDatei As strDir & "Pilot_" & Cluster & "_" & strTMP & strTMP1 & _
strTMP2 & ".pdf"
' Array und Variablen leeren
Erase strTrenn
Cluster = ""
strTMP2 = ""
strTMP1 = ""
strTMP = ""
' Die nächste Datei nehmen
strDatei = Dir$()
Set objDocument = Nothing
Loop
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
Application.ReferenceStyle = lngRef
.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
' Module : Modul1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 20.05.2019
' Purpose : Start Applikation...
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
