VBA Makro gesucht – in datei kopieren mit bedingung und datei mit passwort versehen

[Stoffo]

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.

[schauan]

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

[Stoffo]

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

[schauan]

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 .

[Raoul21]

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.

[Stoffo]

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.

[Stoffo]

Hallo,

hat noch jemand eine Idee?

[schauan]

Hallo Stoffo,

wenn das Arbeitsmappen sind hast Du wohl beim Aufzeichnen nicht alle Hinweise beachtet, insbesondere den:

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.

[Stoffo]

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.

[Raoul21]

Danke, freut mich, dass ich helfen konnte. Alles Gute.