AW: VBA-Code in Sheet importieren
07.12.2018 05:52:49
Hajo_Zi
in dem Link sehe ich keinen Code?
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
Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Die Beiträge werden auch ignoriert, es erfolgt keine Antwort.