Datei wird nicht aktiviert
01.02.2022 12:14:20
kurt
Yal hatte gestern geholfen, das Kopieren, da klappt alles.
Habe nur das Problem:
Wenn ich die Datei in der ich die Adressdaten kopiere, bleibt die Datei aktiv, wenn die Datei vom Laufwerk
geöffnet wurde.
Wenn die Datei schon aktiv ist, bleib ich in der Datei Quelldatei. So sollte es sein.
2. Habe ich die Adresse kopiert, wird in der Ziel Datei die kopierte Zeile komplett selectiert bzw. ist selectiert,
hier sollte der Courser in der 1. kopierten Zelle stehen, wenn möglich.
Anbei beide Makros:
Public Sub Adresse_in_Rechnungs_Datenbank_kopieren()
Dim Qws As Worksheet 'Quell-Worksheet
Dim Zws As Worksheet 'Ziel-Worksheet
Dim ZielZelle As Range
Dim SuchBegriff As String
Dim dn As String
dn = ThisWorkbook.Name
Application.ScreenUpdating = False
'Worksheet-Variable setzen
Set Qws = ActiveSheet
Set Zws = Öffnen("D:\#_Adress_Rechnungs_Datenbank.xlsm").Worksheets("Adressen") 'Öffnen ist Function
Qws.Activate
'Begriff suchen
' SuchBegriff = Qws.Range("C13")
' Set ZielZelle = Zws.Range("B:B").Find(What:=SuchBegriff, After:=Zws.Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'Suchergebnis prüfen: suchBegriff nicht gefunden: Am Ende Anfügen
If ZielZelle Is Nothing Then
Set ZielZelle = Zws.Range("B999999").End(xlUp).Offset(1, 0)
End If
'übertragen
Zws.Unprotect (getStrPasswort)
Qws.Range("C12:C17").Copy
ZielZelle.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Zws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPasswort
Application.CutCopyMode = False
Workbooks(dn).Activate
Qws.Activate
Qws.Range("C12").Select
Application.ScreenUpdating = True
End Sub
Private Function Öffnen(DateiPfad As String) As Workbook
Dim W As Workbook
Dim WBName As String
'---- meine Idee dn ---------------
Dim dn As String
dn = ThisWorkbook.Name
On Error Resume Next
'setze die Datei falls geöffnet
WBName = Mid(DateiPfad, InStrRev("\", DateiPfad) + 1)
Set W = Workbooks(WBName)
'wenn nicht, öffne diese
If W Is Nothing Then
Set W = Workbooks.Open(DateiPfad)
Workbooks(dn).Activate '-- aus meiner Idee
End If
Set Öffnen = W
End Function