PDA

View Full Version : [SOLVED] Modifying VBA code in multiple files



nikki333
12-13-2018, 01:24 PM
Hi Folks

I'm trying to modify VBA Code in multiple files using VBA code :)

The reason for that is that i need to manage/update multiple files containing exactly the same VBA code.
For example, if i see a bug in one file, i'd like to change it and update all the other files with the same code.

So far, I found the instructions on C.Pearson quite interesting (http://www.cpearson.com/Excel/VBE.aspx). It seems that deleting code is very easy, but adding/replacing is a bit of a challenge!

For example this sub deletes all code from a workbook:


Sub DeleteAllVBACode() Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule

Set VBProj = ActiveWorkbook.VBProject

For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp End Sub

Which is good, but I need then to copy all code from the source workbook back into the file; and copying is more cumbersome than deleting.

The question is, if anyone has the same needs, and would like to share some code to speed up the process :)

Stohan
12-13-2018, 04:01 PM
Hi

OffTop, but is it easier to use one workbook as the source of the code for the other books. Is the code is exactly the same.

I will have a look at your problem, and will see what I can find about that.

nikki333
02-11-2019, 09:57 AM
I'm still struggling with this one. I've written two subs, one for exporting and one for importing VB code components.

As for the export (subVBKomponentenExportieren):
So far I've managed to programmatically create a folder and export each VB component ( as .txt for workbook/worksheet and .bas for standard modules).
During that procedure, each codecomponent also gets a timestamp (that is inserting one line at the top with a time stamp and an empty line after). This procedure works well, no errors.

As for the import (subVBKomponentenImportieren):
The import, on the other hand, although it used to work many times before, now produces an APPCRASH (VBE7.dll,...); sometimes it happens during the procedure, sometimes right after, and sometimes upon saving or manual compiling.
The crash-causing lines must occur after the "ERROR AFTER HERE" quite at the end of the export sub; since, at that point no break-points are allowed anymore, it's quite difficult to debug. And yes, I'm aware that for this purpose an Addin would be better, but that's not an option right now.
Any idas?

Below, you can see both subs:



'110219@141300

Option Private Module
Option Compare Text
Option Explicit
Option Base 1

'Variablen für dieses Modul dimensionieren
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim fso As New FileSystemObject
Dim fsoTextDatei As TextStream
Dim strCodeMod As String
Dim strDateiPfad As String
Dim strCodeVersion As String
Dim strAnlage As String

'Alle VBE CodeKomponenten als individuelle Dateien exportieren (.txt für Workbook/-sheet Elemente und .bas für Standard Module)
Sub subVBKomponentenExportieren(Optional strVorgängerprozedur As String)

'Variablen dimensionieren/speichern
Dim strExportOrdner As String
Dim strAnlage As String
Dim strJahr As String

On Error Resume Next
strDateiPfad = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "01_RüstCode\"
If Not Err.Number = 0 Then
strDateiPfad = "L:\Operations Produktion\Lindt Production Way\LPW Allgemein\99 Ted\01_Excel_In_Berarbeitung\RüstProjekt\01_RüstCode\"
Err.Clear
End If
Resume 0
strCodeVersion = Replace(Replace(Replace(Now(), ":", ""), ".", ""), " ", "")
strJahr = Mid(strCodeVersion, 5, 4)
strCodeVersion = Replace(strCodeVersion, strJahr, Right(strJahr, 2) & "@")
strAnlage = wsHelfer.Range("B27")
strExportOrdner = strDateiPfad & "RüstCode" & " " & strAnlage & " " & strCodeVersion
Set VBProj = ThisWorkbook.VBProject

'MessageBox Export bestätigen
If strVorgängerprozedur = "btnCodeExportieren" Then
MsgBox "Mit dieser Funktion werden alle in dieser Datei enthaltenen VBA Codekomponenten exportiert und als aktuelle CodeVersion für zukünftiges Importieren gehandhabt!" & vbNewLine & vbNewLine & _
"Wollen Sie fortfahren?", vbInformation + vbOKCancel, "VBA Code exportieren"
End If

'Für jede Codekomponente eine CodeVersion hinzufügen (in die erste Zeile)
For Each VBComp In VBProj.VBComponents
Set CodeMod = VBComp.CodeModule
With CodeMod
If Not .CountOfLines = 0 Then
If InStr(1, .Lines(1, 1), "@") > 0 Then
.ReplaceLine 1, "'" & strCodeVersion & " (Code importiert von " & strAnlage & ")"
Else
.InsertLines 1, "'" & strCodeVersion & " (Code importiert von " & strAnlage & ")"
.InsertLines 2, " "
End If
Else
.InsertLines 1, "'" & strCodeVersion & " (Code importiert von " & strAnlage & ")"
.InsertLines 2, " "
End If
End With
Next VBComp

'Für jede Codekomponente eine Datei erstellen (.txt für Workbook/Worksheet Elemente und .bas für Standard Module)
MkDir (strExportOrdner)
For Each VBComp In VBProj.VBComponents
With VBComp
If .Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
Set fsoTextDatei = fso.CreateTextFile(strExportOrdner & "\" & .Name & ".txt")
strCodeMod = .Lines(1, .CountOfLines)
With fsoTextDatei
.Write strCodeMod
.Close
End With
End With
ElseIf .Type = vbext_ct_StdModule Then
VBProj.VBComponents(.Name).Export Filename:=strExportOrdner & "\" & .Name & ".bas"
End If
End With
Next VBComp

'Codeversion in Dokumentkommentare schreiben
ThisWorkbook.BuiltinDocumentProperties("comments").Value = strCodeVersion

'Projekt kompilieren Status setzten
wsHelfer.Range("B19") = 0

'Aktuelle Datei exportieren (Backup)
subVBKomponentenImportieren "btnDateiExportieren"

End Sub

'Alle VBE CodeKomponenten in aktuelle Datei importieren
Sub subVBKomponentenImportieren(Optional strVorgängerprozedur As String)

'Variablen dimensionieren/speichern
Dim datDatumAktuellerOrdner As Date
Dim datDatumNeusterOrdner As Date
Dim fsoImportOrdner As Object
Dim strImportOrdner As String
Dim strExportOrdner As String
Dim strUpdateModul As String
Dim objDatei As Object
Dim fsoOrdner As Object
On Error Resume Next
strDateiPfad = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "01_RüstCode\"
strExportOrdner = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "03_Dokumente\00_RüstListenVersionen\"
If Not Err.Number = 0 Then
strDateiPfad = "L:\Operations Produktion\Lindt Production Way\LPW Allgemein\99 Ted\01_Excel_In_Berarbeitung\RüstProjekt\01_RüstCode\"
strExportOrdner = "L:\Operations Produktion\Lindt Production Way\LPW Allgemein\99 Ted\01_Excel_In_Berarbeitung\RüstProjekt\03_Dokumente\00_RüstListenVersione n\"
Err.Clear
End If
Resume 0
Set VBProj = ThisWorkbook.VBProject
Set fsoImportOrdner = fso.GetFolder(strDateiPfad)
Set fsoImportOrdner = fsoImportOrdner.SubFolders

'Aktuelle Datei exportieren (Backup)
strCodeVersion = ThisWorkbook.BuiltinDocumentProperties("comments").Value
strAnlage = wsHelfer.Range("B27")
strExportOrdner = strExportOrdner & strAnlage
If Dir(strExportOrdner) = "" Then
MkDir (strExportOrdner)
End If
ThisWorkbook.SaveCopyAs strExportOrdner & "\Rüstliste " & strAnlage & " " & strCodeVersion & ".xlsm"
If strVorgängerprozedur = "btnDateiExportieren" Then
MsgBox "Eine Kopie dieser Datei wurde wie folgt exportiert: " & vbNewLine & vbNewLine & _
strExportOrdner & "\Rüstliste " & strAnlage & " " & strCodeVersion & ".xlsm" & vbNewLine & vbNewLine, vbInformation + vbOKOnly, "Datei Export"
Exit Sub
End If

'Neusten ImportPfad ermitteln
For Each fsoOrdner In fsoImportOrdner
If fsoOrdner.Name Like "*@*" Then
datDatumAktuellerOrdner = fsoOrdner.DateCreated
If strImportOrdner = "" Then
strImportOrdner = fsoOrdner.Path
datDatumNeusterOrdner = datDatumAktuellerOrdner
ElseIf datDatumAktuellerOrdner > datDatumNeusterOrdner Then
datDatumNeusterOrdner = datDatumAktuellerOrdner
strImportOrdner = fsoOrdner.Path
End If
End If
Next fsoOrdner
On Error Resume Next
Set fsoOrdner = fso.GetFolder(strImportOrdner)
strCodeVersion = Mid(strImportOrdner, InStr(1, strImportOrdner, "@") - 6, 13)
If Not Err.Number = 0 Then
MsgBox "Es befinden sich keine CodeVersionen in diesem Ordner!", vbInformation + vbOKOnly, "Fehlende CodeVersionen"
Exit Sub
End If
Resume 0

'>>>ERROR AFTER HERE<<<

'Modulnamen
For Each VBComp In VBProj.VBComponents
'If Not VBComp.Name Like "*pdate*" Then
If VBComp.Type = vbext_ct_StdModule Then
VBComp.Name = VBComp.Name & "_"
End If
'End If
Next VBComp

'CodeKomponenten importieren
For Each objDatei In fsoOrdner.Files
For Each VBComp In VBProj.VBComponents
If VBComp.Name = Left(objDatei.Name, Len(objDatei.Name) - 4) And Not (VBComp.Name Like "mod*pdate*" Or VBComp.Name Like "mod*UDF*") Then
Set fsoTextDatei = fso.OpenTextFile(objDatei.Path, ForReading, False)
Set CodeMod = VBComp.CodeModule
If objDatei.Name Like "*txt" Then
With fsoTextDatei
strCodeMod = .ReadAll
.Close
End With
With CodeMod
.DeleteLines 1, .CountOfLines
.InsertLines 1, strCodeMod
End With
ElseIf objDatei.Name Like "*bas" Then
If Not objDatei.Name Like "*pdate*" Then
With VBProj.VBComponents
.Remove VBComp
.Import Filename:=objDatei.Path
End With
Else
strUpdateModul = objDatei.Name
End If
End If
Next VBComp
Next objDatei

'Codeversion in Dokumentkommentare schreiben
ThisWorkbook.BuiltinDocumentProperties("comments").Value = strCodeVersion

'Projekt kompilieren Status setzten
wsHelfer.Range("B19") = 0


End Sub