ich habe eine Ausgangsdatei mit verschiedenen Tabellenblättern. Im Ersten werden Daten gesammelt die Tabelle heißt Schichtenprotokoll. In der Tabelle Auswertung werden einige wichtige Daten als Datensatz zusammengefasst. Mittels Button übertrage ich die Daten in eine andere Datei. Das klappt und beschreibt den Istzustand!
Nun möchte ich noch weiter Daten übertragen und tue mich damit schwer, weil der Bereich Leerzeilen hat.
Die Vorgehensweise habe ich mir so vorgestellt, dass ich aus dem Tabellenblatt Auswertung heraus einen Button betätige, der mir wiederum den Bereich A41:Y51 aus der Tabelle Schichtenprotokoll kopiert und in eine Datei STO ab Zeile 4 entweder ohne Leerzeilen einfügt oder mir in der Ziel Datei STO im Tabellenblatt STO1 die Tabelle ab Zeile4 komplett nach Spalte X ohne Leerzeilen sortiert.
Ich füge die Dateien mal mit an, sollte ein Passwort verlangt werden, es gibt keins, also einfach bestätigen.
VBA ist nicht meine Stärke, auch bei diesem Code habe ich Hilfe erhalten, das Forum Excel-Werkstatt, die mir in Sachen VBA immer sehr geholfen haben, ist leider nicht mehr erreichbar. Da ich hier neu bin, bin ich auf Eure Antworten sehr gespannt.
Vielen Dank im Voraus!
Code:
Private Sub CommandButton21_Click()
Dim nwb, awb As Object Dim lzelle As Object
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!!
'Pfad und Dateinamen anpassen 'Tabelle1 gegen den Namen der Ziel/Ursprungstabelle austauschen
Set awb = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken" Set nwb = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsx") 'Exceldaten, die das Ziel sein _ soll mit Pfad!!!! With nwb.Sheets("STO1") If .Range("a1") = "" Then Set lzelle = Range("a1") 'wenn a1 leer ist bei A2 beginnen Else Set lzelle = .Range("A:Y").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _ LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene _ Zelle im bereich "A:Y" ermitteln End If End With
Mit der Antwort von Peter bzw. dem Hinweis auf den Code für die Leerzeilen, habe ich versucht diesen in meinen Code einzubauen nur leider ohne Erfolg. Er hat mir dann die Leerzeilen aus meiner Übertragungstabelle gelöscht und nicht die in meiner Zieltabelle. Da ich in VBA nicht der fitteste bin, bräuchte ich etwas mehr Hinweise wie und wo ich dann solche Code integrieren kann.
Das hier sollte kein Crossposten sein, da ich das Thema im anderen Forum als abgehandelt beendet hatte, sondern nur der Versuch jemanden zu finden, der mir etwas detaillierter unter die Arme greifen kann.
Danke für Eure Unterstützung.
Gruß Dietmar
Gruß Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
With awb.Sheets("Schichtenprotokoll").Range("A42:y51") Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy 'Kopieren End With
Hallo Uwe, sorry, wer lesen kann ist klar im Vorteil
Es lag daran, das auf dem Tabellenblatt ein Schutz ist, das habe ich wie folgt gelöst.
Code:
awb.Sheets("Schichtenprotokoll").Unprotect With awb.Sheets("Schichtenprotokoll").Range("A42:y51") Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy 'Kopieren End With
Kann ich das so machen?
Gruß Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
With Sheets("Schichtenprotokoll") .Unprotect With .Range("A42:Y51") Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy End With .Protect End With
Gruß Uwe
Folgende(r) 1 Nutzer sagt Danke an Kuwer für diesen Beitrag:1 Nutzer sagt Danke an Kuwer für diesen Beitrag 28 • DietmarD
Hallo Uwe, das ist jetzt super und funktioniert. :18:
Vielen lieben Dank für Deine Geduld mit mir!
Jetzt habe ich eine neue Frage um meine Datei letztendlich perfekt zu machen. Ich möchte meine beiden Schaltflächen die mir nun die Daten in unterschiedliche Dateien schießen zusammenlegen, sodass ich nur ein Button habe. Meine Idee ist den mit Deiner Hilfe erstellten Code in ein Modul zu legen und diesen dann mit Call abzurufen. Wäre der Lösungsansatz vertretbar oder ehr schlecht?
Soll ich dafür einen neuen Thread aufmachen?
Schaltfläche1
Code:
Private Sub CommandButton1_Click()
Dim nwb, awb As Object Dim lzelle As Object
Dim strPasswort As String Dim strPassalt As String strPassalt = "xyz" 'Passwort zum ergleich hier anpassen 'strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage") Application.EnableEvents = False 'Ausschalten eines Ereignisses z.Bsp. Worksheet_Change
If Range("A1") = "0" Then strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage")
If strPasswort = strPassalt Then If MsgBox("Sollen die Daten übertragen werden?", vbYesNo, "Achtung") = vbYes Then
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!! 'Pfad und Dateinamen anpassen 'Tabelle1 gegen den Namen der Ziel/Ursprungstabelle austauschen
Set awb = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken" Set nwb = Workbooks.Open(Filename:="H:\Auswertung\MasterAuswertung.xlsm") 'Exceldaten, die das Ziel sein _ soll mit Pfad!!!! With nwb.Sheets("AuswertungSM4") If .Range("a2") = "" Then Set lzelle = Range("a1") 'wenn a2 leer ist bei A2 beginnen Else Set lzelle = .Range("A:AO").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _ LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:V" ermitteln End If End With
Application.CutCopyMode = False Set lzelle = Nothing Set nwb = Nothing Set awb = Nothing Range("A1").Value = "1" Workbooks("MasterAuswertung.xlsm").Close Savechanges:=True End If Else MsgBox "Du hast ein falsches Passwort eingegeben!" Exit Sub End If Else MsgBox "Die Daten wurden bereits übertragen!"
End If End Sub
Schaltfläche 2
Code:
Private Sub CommandButton21_Click()
Dim nwb, awb As Object Dim lzelle As Object Dim i As Long ' Zeilenzähler
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!!
'Pfad und Dateinamen anpassen 'Tabelle1 gegen den Namen der Ziel/Ursprungstabelle austauschen
Set awb = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken" Set nwb = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsx") 'Exceldaten, die das Ziel sein _ soll mit Pfad!!!! With nwb.Sheets("STO1") If .Range("a1") = "" Then Set lzelle = Range("a1") 'wenn a1 leer ist bei A2 beginnen Else Set lzelle = .Range("A:Y").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _ LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene _ Zelle im bereich "A:Y" ermitteln End If End With
With Sheets("Schichtenprotokoll") .Unprotect 'Blatschutz aufheben With .Range("A42:Y51") Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy 'ohne Leerzeilen kopieren End With .Protect 'Blatt wieder schützen End With
hier hab ich einfach den CB21-Code an CB1-Code angehäng und ein wenig angepasst:
Private Sub CommandButton1_Click() Dim awb As Workbook, nwb As Workbook Dim rngZelle As Range Dim strPasswort As String Dim strPassalt As String
strPassalt = "xyz" 'Passwort zum Vergleich hier anpassen 'strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage") Application.EnableEvents = False 'Ausschalten eines Ereignisses z.Bsp. Worksheet_Change
Set awb = ActiveWorkbook 'Exceldaten, die momentan im zugriff ist "merken" If Range("A1") = "0" Then strPasswort = InputBox("Zum Übertragen bitte Passwort eingeben", "Passwortabfrage") If strPasswort = strPassalt Then If MsgBox("Sollen die Daten übertragen werden?", vbYesNo, "Achtung") = vbYes Then
Application.EnableEvents = True 'Ereigniss wieder einschalten wichtig!!!! 'Pfad und Dateinamen anpassen 'Tabelle1 gegen den Namen der Ziel/Ursprungstabelle austauschen
Set nwb = Workbooks.Open(Filename:="H:\Auswertung\MasterAuswertung.xlsm") 'Exceldaten, die das Ziel sein _ soll mit Pfad!!!! With nwb.Sheets("AuswertungSM4") If .Range("a2") = "" Then Set rngZelle = .Range("a1") 'wenn a2 leer ist bei A2 beginnen Else Set rngZelle = .Range("A:AO").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _ LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:V" ermitteln End If End With
Application.CutCopyMode = False Range("A1").Value = "1" Workbooks("MasterAuswertung.xlsm").Close Savechanges:=True End If Else MsgBox "Du hast ein falsches Passwort eingegeben!" Exit Sub End If Else MsgBox "Die Daten wurden bereits übertragen!" End If
'--------------------------------------------------------------------------------------------------------------------- Set nwb = Workbooks.Open(Filename:="H:\Auswertung\STO.xlsx") 'Exceldaten, die das Ziel sein _ soll mit Pfad!!!! With nwb.Sheets("STO1") If .Range("a1") = "" Then Set rngZelle = Range("a1") 'wenn a1 leer ist bei A2 beginnen Else Set rngZelle = .Range("A:Y").Find(What:="*", after:=.Range("A1"), LookIn:=xlValues, _ LookAt:=xlWhole, searchdirection:=xlPrevious) 'letzte beschriebene Zelle im bereich "A:Y" ermitteln End If End With
With awb.Sheets("Schichtenprotokoll") .Unprotect With .Range("A42:Y51") Application.Intersect(.EntireColumn, .SpecialCells(xlCellTypeConstants).EntireRow).Copy End With .Protect End With nwb.Sheets("STO1").Cells(rngZelle.Row + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False 'Werte einfügen
Application.CutCopyMode = False Workbooks("STO.xlsx").Close Savechanges:=True End Sub
bräuchte ich etwas mehr Hinweise wie und wo ich dann solche Code integrieren kann.
![[-]](https://www.clever-excel-forum.de/images/collapse.png)