AW: Userform entfernen/exportieren
16.06.2014 15:44:43
Hajo_Zi
Option Explicit ' Variablendefinition erforderlich
Option Private Module ' keine Anzeige in der Makroliste
Dim StDatei As String ' Variable Datei
' Zugrifff auf das VBA-Projekt muss zugelassen sein
Sub Code_Exportieren()
Dim StZielPfad As Variant ' Ordner für Zieldatei
Dim StZiel As String ' Variable Dateiname
StDatei = ActiveWorkbook.Name
StZielPfad = Application.GetOpenFilename("Exceldateien (*.xls*), *.xls*", _
, "Zieldatei auswählen")
If StZielPfad "" Or StZielPfad False Then
' Dateiname abtrennen
StZiel = Mid(StZielPfad, InStrRev(StZielPfad, "\") + 1)
If StZiel ActiveWorkbook.Name Then
If InStr(UCase(StZiel), "XL") > 0 Then
Application.DisplayAlerts = False ' Mitteilungen aus
Application.EnableEvents = False ' Reaktion auf Eingabe aus
Workbooks.Open StZiel ' Zieldatei öffnen
' On Error Resume Next ' fehlerbehandlung aus
' Workbooks(StZiel).Worksheets("Muster Vorlage").Visible = True
' Workbooks(StZiel).Worksheets("Muster Vorlage").Delete
' On Error GoTo 0 ' Fehlerbehandlung Standard
' Workbooks(StDatei).Worksheets("Muster Vorlage").Visible = True
' Workbooks(StDatei).Worksheets("Muster Vorlage").Copy Before:=Workbooks(StZiel). _
Sheets(1)
' Workbooks(StZiel).Worksheets("Muster Vorlage").Visible = xlVeryHidden
' Workbooks(StDatei).Worksheets("Muster Vorlage").Visible = xlVeryHidden
' Workbooks(StZiel).Worksheets("Muster Vorlage").Visible = xlVeryHidden
Loeschen_Datei ' vorhandene Dateien löschen
CodeLoeschen ' Code löschen
' Export des Codes
alleMakrosExportieren Workbooks(StDatei).Name
Import StZiel ' Import des Codes
Workbooks(StZiel).Close True ' sichern der Änderungen in Zieldatei
Loeschen_Datei ' vorhandene Dateien löschen
Application.EnableEvents = True ' Reaktion auf Eingabe ein
Application.DisplayAlerts = True ' Mitteilungen ein
End If
Else
MsgBox "Gleiche Datei"
End If
End If
End Sub
Sub Loeschen_Datei()
On Error Resume Next ' Fehlerbehandlung nächste Anweisung
Kill Workbooks(StDatei).Path & "\" & "*.bas" ' vorhandene Moduldateien löschen
Kill Workbooks(StDatei).Path & "\" & "*.FRM" ' vorhandene UserFormdateien löschen
Kill Workbooks(StDatei).Path & "\" & "*.CLS" ' vorhandene Klassendateien löschen
Kill Workbooks(StDatei).Path & "\" & "*.FRX" ' vorhandene Dateien löschen
On Error GoTo 0 ' Fehlerbehandlung Standard
End Sub
Sub CodeLoeschen()
' von Nepumuk, allen vorhandenen Code löschen, in Zieldatei
Dim objVBComponents As Object
With ActiveWorkbook.VBProject
For Each objVBComponents In .VBComponents
Select Case objVBComponents.Type
Case 1, 2, 3
.VBComponents.Remove .VBComponents(objVBComponents.Name)
Case 100
With objVBComponents.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
End Sub
Public Sub alleMakrosExportieren(StDateiExport As String)
' von Nepumuk, Export des gesamten Codes aus ThisWorkbook
Dim vbc As Object, iCounter As Integer, cType As String
For Each vbc In Workbooks(StDateiExport).VBProject.VBComponents
With vbc.CodeModule
For iCounter = 1 To .CountOfLines
If .ProcOfLine(iCounter, 0) > "" Or InStr(1, .Lines(iCounter, 1), "Dim") 0 _
Or InStr(1, .Lines(iCounter, 1), "Public") 0 _
Or InStr(1, .Lines(iCounter, 1), "Type") 0 _
Or InStr(1, .Lines(iCounter, 1), "Static") 0 _
Or InStr(1, .Lines(iCounter, 1), "Declare") 0 Then
Select Case vbc.Type
Case 1: cType = ".bas" ' Module
Case 2, 100: cType = ".cls" ' Tabelle; DieseArbeitsmape; Klassen
Case 3: cType = ".frm" ' UserForm
End Select
' Code Exportieren Ablagepath ThisWorkbook.Path
Workbooks(StDateiExport).VBProject.VBComponents(vbc.Name).Export _
Workbooks(StDatei).Path & "\" & vbc.Name & cType
Exit For
End If
Next iCounter
End With
Next vbc
End Sub
Public Sub Import(StDateiExport As String)
' von Nepumuk
Dim vbc As Object, StDateiname As String
With Workbooks(StDateiExport).VBProject
' Code importieren, UserForm korrekt, sonstiges alles in Klassenmodule
StDateiname = Dir(Workbooks(StDatei).Path & "\" & "*.*")
Do While StDateiname ""
If UCase(Right(StDateiname, 4)) = ".BAS" Or UCase(Right(StDateiname, 4)) = ".FRM" _
Or UCase(Right(StDateiname, 4)) = ".CLS" Then
.VBComponents.Import Workbooks(StDatei).Path & "\" & StDateiname
End If
StDateiname = Dir
Loop
' Code auf DieseArbeitsmappe und Tabellen (interner Name) verteilen
For Each vbc In .VBComponents
If vbc.Type = 2 Then
' alle Klassen beginnen mit cls und müssen nicht verteilt werden
If UCase(Left(vbc.Name, 3)) "CLS" Then
' Code an die entsprechenden Stelle kopieren
.VBComponents(Left(vbc.Name, Len(vbc.Name) - 1)).CodeModule.InsertLines 1, _
_
vbc.CodeModule.Lines(1, vbc.CodeModule.CountOfLines)
' Code in Klasse löschen
.VBComponents.Remove .VBComponents(vbc.Name)
End If
End If
Next vbc
End With
End Sub
Gruß Hajo