Daten kopieren

Sub Adresse_in_Rechnungs_Datenbank_kopieren() Application.ScreenUpdating = False Dim dn As String dn = Application.ActiveWorkbook.Name ActiveSheet.Range("C12:C17").Select Selection.Copy ActiveSheet.Unprotect (getStrPasswort) Windows("##_Adress_Rechnungs_Datenbank.xlsm").Activate Sheets("Adressen").Select Dim zz As String zz = 1 Do While Cells(zz, 1) "" ' Start der Schleife 1=Spalte A zz = zz + 1 ' Schleifenzähler um 1 erhöhen Loop ' Wendepunkt für Schleife Cells(zz, 1).Select ' Zelle selektieren 1=in Spalte A anfang Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True ActiveCell.Offset(0, 0).Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _ :=True, Password:=getStrPasswort Workbooks(dn).Activate Application.CutCopyMode = False Application.ScreenUpdating = True Range("C12").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kurt,
Kopieren, ohne zu öffnen? Nein. Wenn Du aus der Mappe, die Du Datenbank nennst, lesen würdest, dann könnte man per Formel Daten lesen, ohne die Quelle zu öffnen. Beim Schreiben, ist die Datenbank-Mappe das Ziel. Muss geöffnet werden.
Prüfen, ob eine Wert vorhanden ist, geht es mit der Suche. Was würde dann passieren? der bisherige Eintrag überschreiben?
Dein Coding ist ein BIschen umständlich, aber bis auf einem Punkt ok: nach dem was ich sehe, machst Du einen "Unprotect" auf das Blatt, die Du liest, und dann einen Protect auf das Blatt, wo es reingeschrieben wird. Ist es so gewollt? Hilfsmittel: weise die Blätter zu Variablen. Blätter sind Objekt und müssen mit "Set " einer Variable zugewiesen werden.
es geht so:


Sub Adresse_in_Rechnungs_Datenbank_kopieren()
Dim Qws As Worksheet 'Quell-Worksheet
Dim Zws As Worksheet 'Ziel-Worksheet
Application.ScreenUpdating = False
Set Qws = ActiveSheet
Set Zws = Workbooks("##_Adress_Rechnungs_Datenbank.xlsm").Worksheets("Adressen")
Qws.Range("C12:C17").Copy
Zws.Unprotect (getStrPasswort)
Zws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Zws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPasswort
Application.CutCopyMode = False
Qws.Activate
Qws.Range("C12").Select
Application.ScreenUpdating = True
End Sub

Mit Suchfunktion sieht es so aus:


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
Application.ScreenUpdating = False
'Worksheet-Variable setzen
Set Qws = ActiveSheet
Set Zws = Workbooks("##_Adress_Rechnungs_Datenbank.xlsm").Worksheets("Adressen")
'Begriff suchen
SuchBegriff = Qws.Range("C12")
Set ZielZelle = Zws.Find(What:=SuchBegriff, After:=Zws.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, 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("A99999").End(xlUp).Offset(1, 0)
End If
'Übertragen
Qws.Range("C12:C17").Copy
Zws.Unprotect (getStrPasswort)
ZielZelle.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Zws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPasswort
Application.CutCopyMode = False
Qws.Activate
Qws.Range("C12").Select
Application.ScreenUpdating = True
End Sub

VG
Yal

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 Application.ScreenUpdating = False 'Worksheet-Variable setzen Set Qws = ActiveSheet Set Zws = Öffnen("D:\xxx\##_Adress_Rechnungs_Datenbank.xlsm").Worksheets("Adressen") 'Begriff suchen SuchBegriff = Qws.Range("C12") Set ZielZelle = Zws.Range("A:A").Find(What:=SuchBegriff, After:=Zws.Range("A1"), 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("A99999").End(xlUp).Offset(1, 0) End If 'übertragen Qws.Range("C12:C17").Copy Zws.Unprotect (getStrPasswort) ZielZelle.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Zws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPasswort Application.CutCopyMode = False 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 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) End If Set Öffnen = W End Function

Private Function Öffnen(DateiPfad As String) As Workbook Dim W As Workbook Dim WBName As String 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) End If Set Öffnen = W End Function

Private Function Öffnen(DateiPfad As String) As Workbook Dim W As Workbook Dim WBName As String On Error Resume Next '---- meine Idee dn --------------- Dim dn As String dn = ThisWorkbook.Name '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) End If Set Öffnen = W Workbooks(dn).Activate End Function

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread