getObject Zeile auf Inhalt überprüfen
29.07.2020 11:12:36
Henry
wiedereinmal bin ich auf eure Hilfe angewiesen:
Mein Makro soll für das Speichern eines Prüfprotokolls einen Namen vorschlagen und nach dem Speichervorgang bestimmte Werte in eine andere Tabelle (fungiert als Datenbank für die gemessenen Werte) abspeichern.
Nun soll geprüft werden, ob bei einem vorherigen Speichervorgang schon Werte eingetragen wurden. Hierfür soll in der Datenbank "test.xlsm" nach dem Dateinamen der Datei vor dem aktuellen Speichern "alter_name" gesucht werden und sämtliche Zeilen welche ihn beinhalten gelöscht werden. Anschließend werden die neuen Daten wieder in die Datenbank eingetragen.
Vorab schon einmal ein Danke für eure Hilfe
Problem:
Die Datenbank wird zwar geöffnet und durchsucht aber es wird nie etwas
gefunden, obwohl der Dateiname vorhanden ist.
Wird nur der folgende Teil des gesamten Codes ausgeführt funktioniert es
Sub test()
Dim RaFound As Range
Zieldatei_pfad = "Muster" & "\" 'Pfad in der Ziledatei liegt
Zieldatei = "test.xlsm" 'Bezeichnung Zieldatei in die Hyperlink geschrieben werden soll
'akutellen Name & Pfad speichern
aktueller_pfad = ActiveWorkbook.Path & "\"
aktueller_name = ActiveWorkbook.Name
alter_name = Range("AG1")
'Zieldatei öffnen, durchsuchen
GetObject (Zieldatei_pfad & Zieldatei)
Application.AskToUpdateLinks = False
GetObject (Zieldatei_pfad & Zieldatei)
With Worksheets("Tabelle1").Columns(14)
Set RaFound = .Cells.Find(alter_name, , , xlWhole, , xlNext)
If Not RaFound Is Nothing Then
Rows(RaFound.Row).Delete
Do
Set RaFound = .Cells.Find(alter_name, , , xlWhole, , xlNext)
If RaFound Is Nothing Then Exit Do
Rows(RaFound.Row).Delete
Loop
End If
End With
Set RaFound = Nothing
End Sub
Global speichern_gedrückt As Boolean
Global speichern_abgebrochen As Boolean
Sub speichern()
Dim aktueller_pfad As String
Dim aktueller_name As String
Dim Zieldatei_pfad As String
Dim Zieldatei As String
Dim Lrow As Long
Dim i As Integer
Dim j As Integer
Dim k As Integer
j = Range("AC2")
k = Range("AD2")
i = 21 + 2 * j
'Felder für Dateinamenvorschlag definieren
Lab_nummer = Range("J6")
Datum = Range("j8")
Bearbeiter = Range("j10")
Lieferant = Range("J12")
If Range("AD1") = "Wahr" Then
Messbericht = "vorhanden"
Else
Messbericht = "nicht vorhanden"
End If
Bewertung = Range("AF2")
speichern_gedrückt = True
'Dateinamen vorschlagen
If Lab_nummer = False Or Datum = False Or Bearbeiter = False Then
userResponce = Application.Dialogs(xlDialogSaveAs).Show
Else
userResponce = Application.Dialogs(xlDialogSaveAs).Show(Lab_nummer & Format("-") _
& Cells(i, 3) & Format("-") _
& Cells(i, 4) & Format("-") _
& Cells(i, 5) & Format("-") _
& Cells(i, 6) & Format("-") _
& Datum)
End If
'Überprüfen ob Abbrechen gedrückt wurde, falls Ja Code beenden
If userResponce = False Then
GoTo ende
End If
Application.ScreenUpdating = False
Zieldatei_pfad = "Muster" 'Pfad in der Ziledatei liegt
Zieldatei = "test.xlsm" 'Bezeichnung Zieldatei in die Hyperlink geschrieben werden soll
'akutellen Name & Pfad speichern
aktueller_pfad = ActiveWorkbook.Path & "\"
aktueller_name = ActiveWorkbook.Name
alter_name = Range("AG1")
Range("AG1") = ActiveWorkbook.Name
'Zieldate öffnen, Hyperlink schreiben, speichern, schließen
GetObject (Zieldatei_pfad & Zieldatei)
Application.AskToUpdateLinks = False
Application.Visible = True
With Workbooks(Zieldatei)
With Worksheets("Tabelle1").Columns(14)
Set RaFound = .Cells.Find(alter_name, , , xlWhole, , xlNext)
If Not RaFound Is Nothing Then
Rows(RaFound.Row).Delete
Do
Set RaFound = .Cells.Find(alter_name, , , xlWhole, , xlNext)
If RaFound Is Nothing Then Exit Do
Rows(RaFound.Row).Delete
Loop
End If
End With
Set RaFound = Nothing
End With
Do
If Not IsEmpty(Cells(i, 2)) Then
If IsNumeric(Cells(i, 2)) Then
With Workbooks(Zieldatei).Worksheets("Tabelle1")
Lrow = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 'letzte Zeile in _
Zieldatei +1
End With
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 1) = Lab_nummer
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 2) = Datum
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 3) = Bearbeiter
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 4) = Lieferant
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 5) = Messbericht
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 12) = Bewertung
Workbooks(Zieldatei).Worksheets("Tabelle1").Cells(Lrow, 14) = aktueller_name
Range(Cells(i, 3), Cells(i, 8)).Copy 'Werte Kopieren
With Workbooks(Zieldatei).Worksheets("Tabelle1")
.Hyperlinks.Add Anchor:=.Cells(Lrow, 13), Address:=aktueller_pfad & "\" & _
aktueller_name, TextToDisplay:="Hyperlink"
.Cells(Lrow, 6).PasteSpecial Paste:=xlPasteValues
End With
Else:
'nichts ausführen
End If
End If
i = i + 1
Loop Until i = 47 + 2 * j + k
Application.AskToUpdateLinks = True
Workbooks("test.xlsm").Close True
MsgBox "Datei gespeicht und Daten erfolgreich übernommen", vbInformation, "Hinweis"
ende:
speichern_gedrückt = False
Application.ScreenUpdating = True
End Sub