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)