AW: Range.Find-Methode mit zwei Variablen
04.01.2021 17:33:13
Nepumuk
Hallo Andl,
so ok?
Option Explicit
Public Sub DatenHolenAusRechnungsjournal()
Const FOLDER_PATH As String = "W:\Projekt Fact\"
Dim Zeile As Long
Dim Treffer1 As Range
Dim Treffer2 As Range
Dim strFirsAddress As String
Dim QName As String
Dim LetzteZeileEinspieldaten As Long
Dim QPartnernummer As String
Dim QListennummer As String
Dim QMonatsreferenz As String
Dim QSumme As Single
Dim strName As String
Dim objCell1 As Range, objCell2 As Range
Dim ListenNummer As Long
Dim NächsteListenNummer As Long
Dim NächsteListenNummer6stellig As String
Dim LetzterFakturaMonat As Long
Dim Quelle As Workbook
Dim strFilename As String
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
strName = ActiveSheet.Name
With Tabelle13
Set objCell1 = Tabelle13.Columns(2).Find(What:=strName, LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
Set objCell2 = Tabelle13.Columns(2).Find(What:=strName, LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=True)
ListenNummer = Application.Max(.Range(objCell1.Offset(0, 1), objCell2.Offset(0, 1)))
LetzterFakturaMonat = Application.Max(.Range(objCell1.Offset(0, 2), objCell2.Offset(0, 2)))
End With
Set objCell1 = Nothing
Set objCell2 = Nothing
NächsteListenNummer = ListenNummer + 1
NächsteListenNummer6stellig = Format$(NächsteListenNummer, "000000")
'Debug.Print objCell1
'Debug.Print NächsteListenNummer
'Debug.Print NächsteListenNummer6stellig
'Debug.Print LetzterFakturaMonat
Do
strFilename = Dir$(FOLDER_PATH & "*_" & strName & "_" & NächsteListenNummer6stellig & ".xlsx")
If strFilename <> vbNullString Then
'Bei erstmaligem anlegen eines neuen Partners, muss die EinspielDatei manuell definiert werden
'Set Quelle = Workbooks.Open(ThisWorkbook.Path & "\202010_333_000360.xlsx")
'Bei bereits bestehenden Einspieldateien aktivieren
Set Quelle = GetObject(PathName:=FOLDER_PATH & strFilename)
With Quelle.Worksheets(1)
For Zeile = 7 To .Cells(.Rows.Count, 5).End(xlUp).Row
'Wo wird gesucht nach was? Wie? Nur Eindeutige Nummern
Set Treffer1 = Columns(5).Find( _
What:=.Cells(Zeile, 5).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Treffer1 Is Nothing Then
'Nr muss neu angelegt werden
Call CopyValues(.Cells(Zeile, 1))
Else
'erste Fundstelle merken
strFirsAddress = Treffer1.Address
'wenn in Spalte C ein anderer Wert steht
If .Cells(Zeile, 3).Value <> Treffer1.Offset(0, -2).Value Then
'Zweite Artikelnummer suchen
Set Treffer2 = Columns(5).FindNext(After:=Treffer1)
'wenn keine weitere Fundstelle
If Treffer2.Address = strFirsAddress Then
'Nr muss zusätzlich angelegt werden
Call CopyValues(.Cells(Zeile, 1))
Else
'zweite Artikelnummer gefunden Spalte E ändern
Cells(Treffer2.Row, 5).Value = .Cells(Zeile, 5).Value
End If
Else
'erste Artikelnummer gefunden Spalte E ändern
Cells(Treffer1.Row, 5).Value = .Cells(Zeile, 5).Value
End If
End If
Next Zeile
' Eingeleser Quelldateiname wird in nachfolgende Zeile geschrieben
QName = Quelle.Name
QListennummer = Left$(Right$(QName, 11), 6)
QPartnernummer = Right$(Left$(QName, 10), 3)
QMonatsreferenz = Left$(QName, 6)
QSumme = .Cells(.Rows.Count, 11).End(xlUp).Value
With Tabelle13
LetzteZeileEinspieldaten = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & LetzteZeileEinspieldaten).Value = QName
.Range("B" & LetzteZeileEinspieldaten).Value = QPartnernummer
.Range("C" & LetzteZeileEinspieldaten).Value = QListennummer
.Range("D" & LetzteZeileEinspieldaten).Value = QMonatsreferenz
.Range("E" & LetzteZeileEinspieldaten).Value = QSumme
.Range("F" & LetzteZeileEinspieldaten).Value = Date
End With
End With
Quelle.Close SaveChanges:=False
Set Quelle = Nothing
Set Treffer1 = Nothing
Set Treffer2 = Nothing
With Tabelle13
Set objCell1 = .Columns(2).Find(What:=strName, LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
Set objCell2 = .Columns(2).Find(What:=strName, LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=True)
ListenNummer = Application.Max(.Range(objCell1.Offset(0, 1), objCell2.Offset(0, 1)))
LetzterFakturaMonat = Application.Max(.Range(objCell1.Offset(0, 2), objCell2.Offset(0, 2)))
End With
NächsteListenNummer = ListenNummer + 1
NächsteListenNummer6stellig = Format(NächsteListenNummer, "000000")
Else
Exit Do
End If
Loop
Call CopyFormulas
'Abschließendes Sortieren
Range(Cells(2, 1), Cells(Rows.Count, 29)).Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes
'Format der Überschrift in letzte Zeile kopieren
Call Range("A2:AC2").Copy
Call Cells(Rows.Count, 1).End(xlUp).PasteSpecial(Paste:=xlPasteFormats)
'Formatierung Tabelle2
With Tabelle13
.Columns(1).HorizontalAlignment = xlLeft
.Columns(2).NumberFormat = "#,##0"
.Columns(2).HorizontalAlignment = xlCenter
.Columns(3).NumberFormat = "#,##0"
.Columns(3).HorizontalAlignment = xlCenter
.Columns(4).NumberFormat = "00000"
.Columns(4).HorizontalAlignment = xlCenter
.Columns(5).NumberFormat = "#,##0.00"
.Columns(5).HorizontalAlignment = xlRight
.Columns(6).HorizontalAlignment = xlRight
End With
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
MsgBox "Es wurden alle neuen Rechnungen von Partner ''" & _
strName & "'' eingelesen", vbInformation, "Rechnungsaktualisierung"
End Sub
Gruß
Nepumuk