In einem Hauptordner ist eine Datei, davon Teile kopiert in neues Tabellenblat, dies abspeichern in vorhandenen Unterordner mit VBA

Question

Ich habe einen Hauptordner mit einem Tabellenblatt. Davon kopiere ich eine Teil davon in eine neue Datei und benenne sie nach einem Namen. Diese neu erstellte Tabelle möchte ich in einen neuen vorhandenen Unterordner abspeichern. Bei mir ist das auf D: gespeichert. Das ganze soll aber weitergegeben werden, wobei man nicht weiß, auf welche Partition wo anders gespeichert wird, deshalb ist per VBA der Pfad immer automatisch anzupassen.
Mir gelingt das einfach nicht . Ich arbeite mit Win 7 und Win 10 und Excel 2013.

Hauptordner -Wanderstatistik mit Tabelle-Wanderstatistik
Im Hauptordner Wanderstatistik befindet sich auch noch der Unterordner LeereStatistikblätter.

In der Tabelle Wanderstatistik wiederholt sich mehrmals ein gleicher Abschnitt jeweils mit anderem Namen versehen. Jeden Abschnitt kopiere ich in eine neue Tabelle, diese möchte ich in den vorhandenen Unterordner LeereStatistikblätter kopieren um diese später an die einzelnen Namen zum ausfüllen zu versenden.
Bis jetzt sieht es bei mir so aus:
Sub Makro3()
'
Dim i As Integer
Dim ewert As String
Dim ewert2 As String 'Ortsgruppenname für titelnammen des neuen Einzelblattes
Dim Ordner As String
'
' Ortsgruppen-Meldungsformular zum E-Maile Versand oder Ausdruck auf dem Bildsdchirm erstellen
'
Beep
strJahreszahl = InputBox("Die Jahreszahl vom Jahresblatt, von welchem die Leere-Ortsgruppen-Meldeformulare" & Chr(13) & _
"erstellt werden sollen, eingeben!", "Neue Leere-Ortsgruppen-Meldeformular", XPos:=11000, YPos:=5000)
Worksheets(strJahreszahl).Select
'
Beep
i = MsgBox("Ist das das richtige Jahresblatt, von dem" & Chr(13) & _
"die Ortsgruppen-Meldeformulare erstellt werden sollen???", vbYesNo + vbDefaultButton2, " Sicherheitsabfrage!")
'
If i = 7 Then Exit Sub
'
ActiveSheet.Protect ("fgv")
'
ActiveSheet.Unprotect ("fgv")
Range("D19:D3690").Activate
Selection.EntireRow.Hidden = False
'
Beep
ewert = InputBox("Die Lfd. Nr der gewünschten Ortsgruppe eingeben!!!" & Chr(13) & _
"Wenn mann die richtige Nr. erst noch nachsehen will, die Abbrechen-Taste drücken und beginne nochmal. ", vbYesNo + vbDefaultButton2)
'
If ewert = "" Then
If ActiveCell = Not IsNumeric(Nr) Then 'Sicherung bei nicht ausgewählter Ortsgruppennummer
' oder wenn das ausgewählte Feld keine Zahl ist
MsgBox "Es wurde keine richtige Ortsgruppen-Nr. eingegben!" + Chr(13) + "Beginnen Sie nochmal !"
Exit Sub
End If
End If
' zum gesuchten Ortgruppen Formular springen
ActiveSheet.Unprotect ("fgv")
Range("D1").Select
Cells.Find(What:=ewert, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:= _
xlByColumns, SearchDirection:=xlNext, MatchCase:=False). _
Activate
'
ActiveWindow.SmallScroll Up:=-19
ActiveCell.Offset(0, 9).Range("A1").Select
ewert2 = ActiveCell
ActiveCell = ewert2
'
ActiveCell.Offset(0, -8).Range("A1:M48").Select
Selection.Copy
'
Workbooks.Add ' erstellt ein neues WorkSheetBlatt
ActiveWindow.Caption = ewert2 ' neue benennt das Dateiblatt (ganz oben grau) nach dem Ortsgruppennamen
'Dim tabname As String
ActiveSheet.Name = ewert2 'benennt da Blatt (Reiter unten)nach der Ortsgruppe
'
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(4, 7).Range("A1").Select
Windows("Wanderstatistik2.xlsm").Activate
ActiveCell.Offset(0, 8).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Windows(ewert2).Activate
Range("I1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Wanderstatistik2.xlsm").Activate
ActiveWindow.SmallScroll Down:=42
ActiveCell.Offset(47, -8).Range("A1:F4").Select
Application.CutCopyMode = False
Selection.Copy
Windows(ewert2).Activate
ActiveWindow.SmallScroll Down:=24
ActiveCell.Offset(47, -8).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(-47, 0).Range("A1").Select
Application.CutCopyMode = False
'
ActiveSheet.Protect ("fgv")
'
'
'Workbooks(LeereOrtgrMeldeForm2015).Select
'Workbooks.Open (ThisWorkbook.Path & "\" & "LeereOrtgrMeldeForm2015")
Pfad = ThisWorkbook.Path & LeereOrtgrMeldeForm2015 & ewert2
'ewert2 'gibt an wohin und mit welcher Bezeichnung der Ordner erstellt wird"
' Ord = ActiveWorkbook
ActiveWorkbook.Save 'As Filename:=Pfad ' & (LeereOrtgrMeldeForm2015) &"\"(ewert2) '.xlsm" ' & Mnt & ".xls", FileFormat:=??

' ActiveWorkbook.SaveAs Filename:=Pfad & "BAB für die IT" & Mnt & ".xlsm", FileFormat:=??
'
ActiveWindow.Close
ActiveCell.Offset(-16, 15).Range("A1").Select
ActiveWindow.SmallScroll Down:=-123
ActiveCell.Offset(-111, -15).Range("A1").Select

'End If

End Sub

Für Hilfe dazu wäre ich dankbar

Answer 1

Ich möchte noch eine Erklärung anhängen.
Es funktioniert alles wie gewünscht, nur am Schluss das abspeichern in den Unterordner nicht.. ich lese den Pfad des großen Worksheets aus und will da zu diesem Pfad den Unterordner zum Abspeichern hinzufügen. Das gelingt mir nicht. habe schon viele Varianten ausprobiert, deshalb auch am Schluss das Durcheinander.

Horst

Answer 2

Hallo,

wenn du ein Verzeichnis per VBA anlegen willst, dann probier es mal so:

Pfad = ThisWorkbook.Path & LeereOrtgrMeldeForm2015 & ewert2
'ewert2 'gibt an wohin und mit welcher Bezeichnung der Ordner erstellt wird
If Dir(Pfad, vbDirectory) = "" Then MkDir (Pfad)
ActiveWorkbook.SaveAs Filename:=Pfad & "\BAB für die IT" & Mnt & ".xlsm"

Ich hoffe, ich habe dich richtig verstanden.

Gruß

M.O.

Answer 3

Hallo M.O.
danke für die schnelle Antwort.
Es funktioniert leider nicht.
Pfad = ThisWorkbook.Path & LeereOrtgrMeldeForm2015 & ewert2, bei

ThisWorkbook.Path lese ich aus wo sich das alles befindet, die Partition und das Excelblatt.

" LeereOrtgrMeldeForm2015" ist der vorhandene Unterordner, welcher sich auch in diesem Hauptordner befindet und in welchem ich das neu erstellte Dateiblatt(nach den Namen benannt) abspeichern will. In diesem sollen noch nach diesem System weitere neu erstellte mit anderen Namen versehene Dateiblätter eingefügt werden.

"ewert2" ist immer der Name der neu erstellte Tabelle, welche in den Unterordner " LeereOrtgrMeldeForm2015" eingefügt werden soll.

MfG

freind

Answer 4

Hallo,

der folgende Codeteil prüft, ob im Speicherpfad der aktuellen Arbeitsmappe das Verzeichnis "LeereOrtgrMeldeForm2015" existiert, legt das Verzeichnis ggf. an und speichert die aktive Arbeitsmappe unter dem Namen, der in der Variabel ewert2 definiert ist, als XLSM-Datei in dem Verzeichnis ab:

Pfad = ThisWorkbook.Path & "\LeereOrtgrMeldeForm2015"
If Dir(Pfad, vbDirectory) = "" Then MkDir (Pfad)
ActiveWorkbook.SaveAs Filename:=Pfad & "\" & ewert2 & ".xlsm"

Gruß

M.O.

Answer 5

Hallo M.O.,

funktioniert nicht ganz.

Es wird das neu erstellte Excelblatt oben im grauen Bereich vom Namen(z.b. Arzberg) umbenannt in "LeereOrtgrMeldeForm2015" und unter diesem Namen im Hauptordner zusätzlich eingefügt - nicht als Excelblatt mit dem Namen "Arzberg" in den vorhandenen Unterordner "LeereOrtgrMeldeForm2015".

MfG

freind

Answer 6

Hallo,

das liegt aber nicht an meinem Makroschnipsel, sondern an deinem Code.

Hier mal ein Beispiel, wie man eine neue Arbeitsmappe anlegt:

Sub leere_Arbeitsmappe_anlegen()
Dim neuesWB As Workbook
Dim nwbName As String

Set neuesWB = Workbooks.Add
nwbName = neuesWB.Name
MsgBox nwbName
End Sub

Und bezogen auf deinen Code (Daten aus aktueller Arbeitsmappe in neu angelegte Mappe kopieren und diese Mappe speichern):

Sub Beispiel_freind()
Dim neuesWB As Workbook
Dim nwbName As String
Dim ewert2 As String
Dim Pfad As String

ewert2 = "Test"

Pfad = ThisWorkbook.Path & "\LeereOrtgrMeldeForm2015"
'ewert2 'gibt an wohin und mit welcher Bezeichnung der Ordner erstellt wird
If Dir(Pfad, vbDirectory) = "" Then MkDir (Pfad)

'neues Worbook anlegen
Set neuesWB = Workbooks.Add
nwbName = neuesWB.Name

'Daten aus aktiver Arbeitsmappe kopieren
ThisWorkbook.ActiveSheet.Range("A1:M48").Copy

'hier wird jetzt das neue Workbook angesprochen
With Workbooks(nwbName)
.ActiveSheet.Name = ewert2 'aktives Blatt umbenennen
With .Worksheets(ewert2).Range("I1") 'kopierte Daten in I2 einfügen
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
.SaveAs Filename:=Pfad & "\" & ewert2 'und neue Arbeitsmappe speichern
End With
End Sub

Gruß

M.O.

Answer 7

Hallo M.O.,

danke für Ihre Antwort.
Seit heute morgen bin ich wieder am tüfteln.
Ihr Vorschlag funktioniert einwandfrei aber der Ordner "LeereOrtgrMeldeForm2015" in welchen das neue Blatt eingefügt werden soll, existiert schon. Es muss nur das neue Blatt eingefügt werden (insgesamt ca. 30, jedes mit einem anderen Namen).
Für jedes Jahr wird dieser "LeereOrtgrMeldeForm2015" automatisch neu erstellt, mit dem Unterschied, das hinten eine neue Jahreszahl angehängt ist.
Es müsste da bei jedem anderen Jahr das Makro geändert werden.
Ich habe da vorher bei der Pfadangabe den Pfad mit einem ewert zu ergänzen versucht, aber daran bin ich ja gescheitert .

MfG

freind

Answer 8

Hallo,

dann erstelle den Pfad mit einer Variable für die Jahreszahl:

Pfad = ThisWorkbook.Path & "\LeereOrtgrMeldeForm" & Jahr

Dabei steht "Jahr" für die Variable für die Jahreszahl. Falls ewert deine Jahreszahl enthält, dann musst du Jahr durch ewert ersetzen.

Gruß

M.O.

Answer 9

Hallo M.O.

Danke für die außergewöhnlich ausgiebige Hilfe.
Jetzt passt es.

Ich wollte noch markieren das Problem ist gelöst, aber ich komme da nicht zurecht, da wieder dazu ein Kennwort verlangt wird aber das Kennwort funktioniert da wieder nicht oder ich bin zu Begriffsstutzig

Nochmals herzlichen Dank für die Hilfe und herzliche Grüße!

freind