Hallo zusammen,
ich benötige ein Makro, welches mir aus einer Datei Daten kopiert, wenn eine bestimmte Bedingung erfüllt ist. Diese Daten sollen dann in einen bestimmten Bereich einer anderen Datei kopiert werden. Letzlich soll im Anschluss die Datei unter einem bestimmten Namen via speichern unter abgespeichert werden und im besten fall der Reiter nebst Bereich in den die Daten eingefügt wurden ausgeblendet werden. Die Krönung wäre dann, wenn die so entstandene neue Datei mit einem Passwort versehen werden könnte und ein Arbeitsmappenschutz mit einem weiteren Passwort eingerichtet werden würde.
Als Beispiel:
Arbeitsmappe 1 enthält die zu kopierenden Daten
Arbeitsmappe 2 ist die "Zielvorlage" in die die kopierten Daten eingefügt werden sollen
Arbeitsmappe 3 ist dann die "neue Datei auf Grundlage der Zielvorlage"
1. In Arbeitsmappe 1 soll im ersten Reiter ab Zeile 2 in den Spalten Z bis AE Zeilenweise überprüft werden ob ein Kriterium vorliegt, bspw. ein bestimmter Name.
2. Sofern der Name in der jeweiligen Zeile in einer oder mehreren der Spalten enthalten ist, soll aus dieser Zeile der Inhalt aus dem Bereich A bis AD kopiert werden.
3. Die kopierten Daten sollen nun ohne leere Zwischeneinträge als Werte untereinander in Arbeitsmappe 2 im ersten Reiter im Bereich A6:AD30 eingefügt werden.
4. Das Kriterium (hier ein bestimmter Name) soll in Arbeitsmappe 2 im ersten Reiter in Zelle B1 eingefügt werden.
5. In Zelle E1 und B2 in Arbeitsmappe 2 im ersten Reiter soll der Monatserste des aktuellen Monats hinterlegt werden.
6. Die Datei soll nun unter einem neuen Namen im Format "aktuellerMonat_Fülltext_Kriterium" via speichern unter abgespeichert werden (also bspw. 08 fülltext Mustermann.xlsm)
7. Der erste Reiter der nun entstandenen Arbeitsmappe 3 soll mit einem Passwort versehen werden.
8. Der erste Reiter von Arbeitsmappe 3 soll ausgeblendet werden.
9. Arbeitsmappe 3 soll mit einem passwort zum öffnen versehen werden.
10. Arbeitsmappe 3 soll mit einem Arbeitsmappenschutz versehen werden, das passwort soll sich von dem in schritt 9 unterscheiden.
Ich hoffe mein Anliegen ist verständlich. Ich bin mir nicht sicher, ob alle meine Anforderungen überhaupt per VBA abgebildet werden können, es wäre jedoch sehr nett wenn sich einige Experten der Sache annehmen könnten.
Hi Stoffo,
ob das per VBA möglich ist kannst Du ganz einfach herausbekommen, indem Du mal die Aktion mit dem Makrorekorder aufzeichnest. Siehe dazu meinen Beitrag
Excel-Word-Makrorekorder
Den Code, ggf. auch noch die Datei, kannst Du dann hier einstellen und wir beschäftigen uns damit
Hallo,
zunächst vielen Dank für deine Antwort. Leider scheitere ich bereits am ersten Schritt meines geplanten Makros. Wie mache ich dem Makrorekorder begreiflich, dass er auf ein Kriterium prüfen soll?
Anbei ein erster Versuch
Code:
ActiveWorkbook.Save
End Sub
Sub Makro2()
'
' Makro2 Makro
'
'
Sheets("Arbeitsmappe 1 Reiter 1").Select
Range("A40:AD40").Select
Range("AD40").Activate
Selection.Copy
Sheets("Arbeitsmappe 2 Reiter 1").Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Kriterium"
Range("B2").Select
ActiveCell.FormulaR1C1 = "8/1/2020"
Range("E1").Select
ActiveCell.FormulaR1C1 = "8/1/2020"
Range("E2").Select
ChDir "Speicherpfad"
ActiveWorkbook.SaveAs Filename:="Speicherpfad und Dateiname.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Sheets("Arbeitsmappe 3 Reiter 1").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Arbeitsmappe 3 Reiter 1").Select
ActiveWindow.SelectedSheets.Visible = False
ActiveWorkbook.Protect Structure:=True, Windows:=False
ActiveWorkbook.Save
End Sub
Hallöchen,
ist doch schon mal gut für den ersten Schritt
Du könntest vor dem Kopieren per Autofilter die Daten auf das gewünschte Maß einschränken und den gefilterten Bereich kopieren und einfügen. Das Kriterium würde dann erst mal fest in Deinem Code stehen und wir würden dann den Zellbezug draus machen je nachdem, wie viele Kriterien es sind und in den Autofilter passen, ggf. mit einer Schleife, wenn es zu viele Kriterien werden
.
Hi Stoffo,
individuelle Probleme verlangen nach individuelle Lösungen.
Für Punkt 1 bis 3 hier mal ein VBA-Vorschlag zum Aufwärmen.
Code:
Sub KopierenStoffo()
Dim rQu As Range, rZi As Range
Dim Daten, Kopie
Dim cZe As New Collection
Dim iSp As Long, iZe As Long
Const Suchtext As String = "Bestimmter Name"
With ActiveWorkbook
Set rQu = .Worksheets("Arbeitsmappe1").Range("A2").CurrentRegion
Set rZi = .Worksheets("Arbeitsmappe2").Range("A6")
End With
Daten = rQu
For iZe = 1 To UBound(Daten, 1)
For iSp = 26 To 31
If Daten(iZe, iSp) = Suchtext Then cZe.Add iZe: Exit For
Next iSp
Next iZe
ReDim Kopie(1 To cZe.Count, 1 To 30)
For iZe = 1 To UBound(Kopie, 1)
For iSp = 1 To UBound(Kopie, 2)
Kopie(iZe, iSp) = Daten(cZe(iZe), iSp)
Next iSp
Next iZe
rZi.Resize(UBound(Kopie, 1), UBound(Kopie, 2)) = Kopie
End Sub
Den Code in ein allgemeines Modul kopieren.
Du musst im Code noch den Suchtext richtig eintragen und ev. die Blattnamen "Arbeitsmappe1" und "Arbeitsmappe2" anpassen.
Gruß, Raoul.
Hallo ihr zwei,
zunächst vielen Dank für die Unterstützung.
@schauan:
Code:
Sub Makro1()
'
' Makro1 Makro
'
'
Sheets("Arbeitsmappe 1 Reiter 1").Select
Range("AH1").Select '<-------- Hier wird mein Kriterium ausgewählt via DropDown
ActiveWorkbook.Worksheets("Arbeitsmappe 1 Reiter 1").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Arbeitsmappe 1 Reiter 1").AutoFilter.Sort.SortFields. _
Add2 Key:=Range("AE1:AE79"), SortOn:=xlSortOnValues, Order:=xlDescending _
, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Arbeitsmappe 1 Reiter 1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2:AD2").Select
Range("AD2").Activate
Selection.Copy
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ChDir "C:\irgendwas\nochwas\usw"
ActiveWorkbook.SaveAs Filename:="C:\irgendwas\nochwas\usw\test.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Range("B1").Select
ActiveCell.FormulaR1C1 = "Kriterium" '<---- Hier wird das Kriterium von oben in Arbeitsmappe 2 Reiter 1 Zelle B1 eingefügt
Range("B2").Select
ActiveCell.FormulaR1C1 = "8/1/2020" '<---- Hier soll der jeweilige Monatserste des aktuellen Monats eingetragen werden
Range("E1").Select
ActiveCell.FormulaR1C1 = "8/1/2020" '<---- Hier soll der jeweilige Monatserste des aktuellen Monats eingetragen werden
Range("E2").Select
Sheets("Arbeitsmappe 3 Reiter 1").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Arbeitsmappe 3 Reiter 1").Select
ActiveWindow.SelectedSheets.Visible = False
ActiveWorkbook.Protect Structure:=True, Windows:=False
ActiveWorkbook.Save
End Sub
so sieht es nun aus, ich verstehe darin leider nur Teile, bzw. sieht es für mich so aus als würde eingefügt werden bevor meine Arbeitsmappe 2 geöffnet wird. Darüber hinaus sehe ich zwar, dass der Reiter Ausgeblendet und mit passwort geschützt wird, jedoch würde ich im Makro das Passwort gerne vorgeben können.
@Raoul21
gefällt mir erstmal ziemlich gut, leider kann ich es nicht testen da Du mich wohl missverstanden hast. Arbeitsmappe 1 und 2 sind keine Blattnamen, sondern tatsächliche Arbeitsmappen (Workbooks). Ich weiss jedoch nicht, inwiefern ich deinen Code abändern muss um Arbeitsmappe 2 zu öffnen und in dieser im Reiter 1 (Worksheet) ab A6 einfüge.
Hallo,
hat noch jemand eine Idee?
Hallo Stoffo,
wenn das Arbeitsmappen sind hast Du wohl beim Aufzeichnen nicht alle Hinweise beachtet, insbesondere den:
Zitat:Bevor man mit einer Aufzeichnung beginnt, sollte man beachten, dass der Makrorekorder nur die Aktionen aufzeichnet, die man auch ausführt. Wenn z.B. ein Wechsel zwischen Blättern oder Dateien notwendig sein sollte und man tut das bereits vor der Aufzeichnung, fehlt das anschließend bei der Ausführung des Makros
Ich dachte auch erst, was Dein Blatt für einen ungewöhnlichen Namen hat - Sheets("Arbeitsmappe 1 Reiter 1").Select - , aber (fast) nichts ist unmöglich. Wenn das nun Datei und Blatt sind, würde ein aufgezeichneter code so aussehen - die Datei würde bei mir in C:\Test liegen:
Code:
Sub Makro1()
'
' Makro1 Makro
'
'
Workbooks.Open Filename:="C:\Test\Arbeitsmappe 1.xlsx"
Sheets("Reiter 1").Select
Workbooks.Open Filename:="C:\Test\Arbeitsmappe 2.xlsx"
Sheets("Reiter 1").Select
Windows("Arbeitsmappe 1.xlsx").Activate
End Sub
Damit das Aufzeichnen funktioniert müsstest Du, wie in meinem Beitrag beschrieben, in den beiden Mappen auf Reiter 1 eine andere Zelle auswählen die später am Beginn nicht verwendet wird, jeweils ein anderes Blatt aktivieren, notfalls extra einfügen, die Dateien speichern und schließen und dann erst aufzeichnen.
Du musst auch mal die Reihenfolge überdenken. Dein Schritt 4 könnte man z.B. als ersten Schritt nehmen. Der Benutzer trägt den Namen ein und startet das Makro ...
5. kann man per Formel lösen. 7. ist ggf. nicht nötig, wenn Du die Struktur der Arbeitsmappe schützt. Der Blattschutz würde lediglich verhindern können, dass jemand mit einem Makro auf dem Blatt Daten ändert. Daten rausholen wäre auch bei Blattschutz möglich. Zudem solltest Du das Projekt schützen, damit keiner der den Aufbau der Datei noch nicht kennt, den Blattnamen auf diese Weise sieht.
Hallo zusammen,
nach einigem rumprobieren hier nun mein Ergebnis:
Code:
Sub KopierenStoffo()
Dim rQu As Range, rZi As Range
Dim Daten, Kopie
Dim cZe As New Collection
Dim iSp As Long, iZe As Long
Dim ws As Worksheet
Dim NeuerName As String, Speicherpfad As String
Dim Vorname As String
Dim Name As String
Dim Suchtext As String
Dim passwortEingabe As String
Vorname = InputBox("Bitte den Vornamen eingeben:")
Name = InputBox("Bitte den Nachnamen eingeben:")
passwortEingabe = InputBox("Bitte ein Passwort zum Öffnen der Datei eingeben:")
Suchtext = Name & ", " & Vorname
Speicherpfad = "C:\" 'Hier wird der Speicherpfad festgelegt
NeuerName = Format(Month(Date), "00") & " " & "Datei " & Name & " " & Year(Date) & ".xlsm" 'Hier wird der neue Dateiname vorgegeben
With ActiveWorkbook
Set rQu = .Worksheets("Arbeitsmappe 1 Reiter 1").Range("A2").CurrentRegion
With Application.Workbooks.Open("C:Dateipfad Arbeitsmappe 2")
Set rZi = .Worksheets("Arbeitsmappe 2 Reiter 1").Range("A6")
Set ws = .Worksheets("Arbeitsmappe 2 Reiter 1")
End With
End With
Daten = rQu
For iZe = 1 To UBound(Daten, 1)
For iSp = 26 To 31
If Daten(iZe, iSp) = Suchtext Then cZe.Add iZe: Exit For
Next iSp
Next iZe
ReDim Kopie(1 To cZe.Count, 1 To 30)
For iZe = 1 To UBound(Kopie, 1)
For iSp = 1 To UBound(Kopie, 2)
Kopie(iZe, iSp) = Daten(cZe(iZe), iSp)
Next iSp
Next iZe
rZi.Resize(UBound(Kopie, 1), UBound(Kopie, 2)) = Kopie
With ActiveWorkbook
ActiveSheet.Range("B1").Value = Vorname & Name 'Hier wird der Zelle B1 der Name zugewiesen
ws.Range("B2") = ws.Range("E2") - Day(ws.Range("E2")) + 1 'Hier wird der Zelle B2 und E1 der Monatserste zugewiesen
ws.Range("E1") = ws.Range("E2") - Day(ws.Range("E2")) + 1 'Hier wird der Zelle B2 und E1 der Monatserste zugewiesen
Sheets("Reiter 1").Protect Password:="PasswortfürBlattschutz" 'Hier wird der Reiter 1 mit einem Passwort versehen
Sheets("Reiter 1").Visible = False 'Hier wird der Reiter 1 ausgeblendet
ActiveWorkbook.Protect "PasswortfürArbeitsmappe" 'Hier wird die Arbeitsmappe mit einem Passwort versehen
ActiveWorkbook.SaveAs Filename:=Speicherpfad & NeuerName, Password:=passwortEingabe, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Hier wird die Arbeitsmappe unter neuem Namen und mit Passwort versehen
End With
End Sub
scheint zu tun was es soll, kann man aber bestimmt noch irgendwie verbessern (z.B. durch einen Errorhandler) habe mich damit aber noch nicht weiter beschäftigt. Vielen Dank an euch beide. Ohne Raoul21s Lösungsvorschlag für die Schritte 1-3 und schauans Hilfestellung/Motivation selbst aktiv nach Lösungen zu suchen wäre es wohl nicht zu diesem Ergebnis gekommen.
Danke, freut mich, dass ich helfen konnte. Alles Gute.