AW: Dynamischer Pfadname über ComboBox
23.05.2020 15:52:58
Markus
Hi Regina,
Vielen Dank für deine erneute Antwort.
Bei meiner Mappe handelt es sich um eine Konsolidierung bestehend aus mehreren bestimmten Tabellen aus mehreren Mappen. Es wird immer jeweils die benötigte Monats-Tabelle aus der jeweiligen Mappe ausgelesen. Die Monate werden mit M abgekürzt. Der gewünschte Monat wird auf einer UserForm mittels einer ComboBox (enthält die Monatsnamen: Oktober - September) ausgewählt und anschließend startet das Modul.
Ideal wäre es, wenn du die ComboBox für die unterschiedlichen Benutzer (zB. Peter123 und Anna456) ebenfalls auf der UserForm platzieren könntest. Der Benutzer würde dann in ComboBox1 den Monat wählen und in ComboBox2 seinen jeweiligen Benutzernamen für den Pfadnamen. Anschließend würde er das Makro auslösen (CommandButton1)
Hier das Makro der UserForm:
Option Explicit
Private Sub ComboBox1_Change()
If Me.ComboBox1.Value = "" Then
Monat = ""
Me.CommandButton1.Enabled = False
Else
Select Case Me.ComboBox1.Value
Case Is = "Januar"
Monat = "M01"
Case Is = "Februar"
Monat = "M02"
Case Is = "März"
Monat = "M03"
Case Is = "April"
Monat = "M04"
Case Is = "Mai"
Monat = "M05"
Case Is = "Juni"
Monat = "M06"
Case Is = "Juli"
Monat = "M07"
Case Is = "August"
Monat = "M08"
Case Is = "September"
Monat = "M09"
Case Is = "Oktober"
Monat = "M10"
Case Is = "November"
Monat = "M11"
Case Is = "Dezember"
Monat = "M12"
End Select
Me.CommandButton1.Enabled = True
End If
End Sub
Private Sub CommandButton1_Click() Makro wird ausgeführt
Call Zusammenfuehren(Monat)
Unload Me
End Sub
Private Sub CommandButton2_Click() Schließen Button auf UserForm
Unload Me
End Sub
Private Sub UserForm_Initialize()
With Me.ComboBox1
.AddItem "Januar"
.AddItem "Februar"
.AddItem "März"
.AddItem "April"
.AddItem "Mai"
.AddItem "Juni"
.AddItem "Juli"
.AddItem "August"
.AddItem "September"
.AddItem "Oktober"
.AddItem "November"
.AddItem "Dezember"
End With
Me.CommandButton1.Enabled = False
End Sub
Makro des Moduls (wo der Pfadname entsprechend der Auswahl auf der UserForm - ComboBox2 angepasst werden sollte)
Option Explicit
Dim ws As Worksheet
Dim WBZ As Workbook
Dim Z As Workbook
Dim WBA As Workbook
Dim WBB As Workbook
Dim WBC As Workbook
Dim wsr As Worksheet
Public Monat As String
Dim intIndex As Integer
Dim Punkt As Integer
Sub Zusammenfuehren(ByRef Monat As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.EnableEvents = False
Set WBZ = ThisWorkbook
Set WBA = Workbooks.Open("C:\Users\Peter123\Ordnername\Land1.xlsm")
Set WBB = Workbooks.Open("C:\Users\Peter123\Ordnername\Land2.xlsm")
Set WBC = Workbooks.Open("C: \Users\Peter123\Ordnername\Land3.xlsm")
WBZ.Activate
With WBA
For Each ws In WBA.Worksheets
If InStr(1, ws.Name, Monat, vbTextCompare) > 0 Then
Punkt = InStr(1, WBA.Name, ".", vbBinaryCompare)
intIndex = ws.Index
End If
Next ws
If intIndex 12 Then
MsgBox "Fehler: Tabellenblatt " & Monat & " konnte nicht gefunden werden!" & vbNewLine & "Der Programmablauf wird abgebrochen", vbCritical, "Fehler"
WBA.Close False
WBB.Close False
WBC.Close False
Exit Sub
End If
Set wsr = WBA.Sheets(intIndex)
wsr.Copy after:=WBZ.Sheets(Sheets.Count)
ActiveSheet.Name = Left(WBA.Name, Punkt - 1)
WBA.Sheets("XY").Copy after:=WBZ.Sheets(Sheets.Count)
ActiveSheet.Name = "Land1_XY"
Set wsr = Nothing
.Close False
End With
With WBB
Punkt = InStr(1, WBB.Name, ".", vbBinaryCompare)
Set wsr = WBB.Sheets(intIndex)
wsr.Copy after:=WBZ.Sheets(Sheets.Count)
ActiveSheet.Name = Left(WBB.Name, Punkt - 1)
WBB.Sheets("XY").Copy after:=WBZ.Sheets(Sheets.Count) ' NEW
ActiveSheet.Name = "Land2_XY"
Set wsr = Nothing
.Close False
End With
With WBC
Punkt = InStr(1, WBC.Name, ".", vbBinaryCompare)
Set wsr = WBC.Sheets(intIndex)
wsr.Copy after:=WBZ.Sheets(Sheets.Count)
ActiveSheet.Name = Left(WBC.Name, Punkt - 1)
WBC.Sheets("XY").Copy after:=WBZ.Sheets(Sheets.Count) ' NEW
ActiveSheet.Name = "Land3_XY"
Set wsr = Nothing
.Close False
End With
Set WBA = Nothing
Set WBB = Nothing
Set WBC = Nothing
Sheets("Z").Move after:=Sheets(Sheets.Count)
WBZ.Activate
Set WBZ = Nothing
Set ws = Nothing
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Hoffe es war einigermaßen verständlich - bei Fragen selbstverständlich gerne melden.
Vielen Dank im Voraus für deine Hilfe!