G
Guest
I'm trying to copy modules from one Workbook to another using export and import. I found some very helpful code on Chip Pearson's site Programming to the Visual Basic Editor, thank you.
Using Excel 2000 and Win 98.
The code asks for the first file to update,
- creates an array of all the excel files in the directory of the first file found
For x = 1 to UBound of the array
- opens the first file in the array
- deletes all the code from that workbook including sheets and Thisworkbook
- exports all modules and forms from Thisworkbook (the workbook controlling the copy) and imports them into first file in array (excluding sheets and Thisworkbook - I couldn't get this to work - used a read of each line from a txt file)
- saves the updated file
- closes the updated file
Next x
The first file gets saved
The next file gets opened and the error message EXCEL caused an invalid page fault in EXCEL.EXE comes up.
Following is the code
Option Explicit
Sub UpdateCode()
'Update all modules in all Workbooks in selected directory
Dim x As Integer
Dim TheFileNameArray() As Variant
'Loop to open each excel file in the selected directory
TheFileNameArray = GetTheFileNameArray
For x = 1 To UBound(TheFileNameArray)
'Open and make active the found file
If Not IsEmpty(TheFileNameArray(x)) Then
'The following line causes an invalid page fault in EXCEL.EXE on the second file
Workbooks.Open TheFileNameArray(x)
' MsgBox "Each file name is " & TheFileNameArray(x) & " activeworkbook is " & ActiveWorkbook.Name
'Delete all the modules in the selected file
DeleteAllVBA
Workbooks(TheFileNameArray(x)).Save
'Copy all modules from this workbook
CopyAllModules TheFileNameArray(x)
Workbooks(TheFileNameArray(x)).Save
ActiveWorkbook.Close 'SaveChanges:=True
End If
Next x
End Sub
Function GetTheFileNameArray() As Variant
'Get the name of first file in the selected directory
Dim TheFileName As String, TheFilePath As String
Dim j As Long
Dim f As Variant
Dim FileNameArray() As Variant
Dim x As Integer
TheFileName = Application.GetOpenFileName( _
Title:="Please select any file from the folder that contains the files to be updated, then click Open.")
For j = Len(TheFileName) To 1 Step -1
If Mid(TheFileName, j, 1) = "\" Then Exit For
Next j
TheFilePath = Left(TheFileName, j)
TheFileName = TheFilePath & "*.xls"
f = Dir(TheFileName, vbNormal)
Do Until f = ""
x = x + 1
ReDim Preserve FileNameArray(1 To x)
If f <> ThisWorkbook.Name Then 'Don't update the calling workbook
FileNameArray(x) = f 'Return the file name
End If
f = Dir
Loop
GetTheFileNameArray = FileNameArray
End Function
Sub DeleteAllVBA()
Dim VBComp As VBIDE.VBComponent, VBCompTest As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
Set VBComps = ActiveWorkbook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case vbext_ct_StdModule, vbext_ct_MSForm, _
vbext_ct_ClassModule
'MsgBox "The module name to delete is " & VBComp.Name & " Workbook is " & ActiveWorkbook.Name
VBComps.Remove VBComp
Case Else
'MsgBox "The module name to delete is " & VBComp.Name & " Workbook is " & ActiveWorkbook.Name
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VBComp
End Sub
Sub CopyAllModules(SelectedFile As Variant)
Dim FName As String, ClsFName As String
Dim VBComp As VBIDE.VBComponent
With Workbooks(ThisWorkbook.Name)
FName = .Path & "\code.txt"
If Dir(FName) <> "" Then
Kill FName
End If
For Each VBComp In .VBProject.VBComponents
If VBComp.Type <> vbext_ct_Document Then
VBComp.Export FName
'MsgBox "VBComp name is in Type Not vbext_ct_Document " & VBComp.Name & " VBComp.Type is " & VBComp.Type
Workbooks(SelectedFile).VBProject.VBComponents.Import FName
Kill FName
'Else
' ClsFName = VBComp.Name & ".txt"
' If Dir(ClsFName) <> "" Then
' Kill ClsFName
' End If
' VBComp.Export VBComp.Name & ".txt"
'If ClsFName = "ThisWorkbook" Then
' InsertProcedureCodeFromCode Workbooks(SelectedFile), VBComp.Name, .Path & "\" & ClsFName
' MsgBox "VBComp name is in Type vbext_ct_Document " & VBComp.Name & " VBComp.Type is " & VBComp.Type
' Kill ClsFName
'End If
End If
Next VBComp
End With
End Sub
Please help.
Thank you.
-
Using Excel 2000 and Win 98.
The code asks for the first file to update,
- creates an array of all the excel files in the directory of the first file found
For x = 1 to UBound of the array
- opens the first file in the array
- deletes all the code from that workbook including sheets and Thisworkbook
- exports all modules and forms from Thisworkbook (the workbook controlling the copy) and imports them into first file in array (excluding sheets and Thisworkbook - I couldn't get this to work - used a read of each line from a txt file)
- saves the updated file
- closes the updated file
Next x
The first file gets saved
The next file gets opened and the error message EXCEL caused an invalid page fault in EXCEL.EXE comes up.
Following is the code
Option Explicit
Sub UpdateCode()
'Update all modules in all Workbooks in selected directory
Dim x As Integer
Dim TheFileNameArray() As Variant
'Loop to open each excel file in the selected directory
TheFileNameArray = GetTheFileNameArray
For x = 1 To UBound(TheFileNameArray)
'Open and make active the found file
If Not IsEmpty(TheFileNameArray(x)) Then
'The following line causes an invalid page fault in EXCEL.EXE on the second file
Workbooks.Open TheFileNameArray(x)
' MsgBox "Each file name is " & TheFileNameArray(x) & " activeworkbook is " & ActiveWorkbook.Name
'Delete all the modules in the selected file
DeleteAllVBA
Workbooks(TheFileNameArray(x)).Save
'Copy all modules from this workbook
CopyAllModules TheFileNameArray(x)
Workbooks(TheFileNameArray(x)).Save
ActiveWorkbook.Close 'SaveChanges:=True
End If
Next x
End Sub
Function GetTheFileNameArray() As Variant
'Get the name of first file in the selected directory
Dim TheFileName As String, TheFilePath As String
Dim j As Long
Dim f As Variant
Dim FileNameArray() As Variant
Dim x As Integer
TheFileName = Application.GetOpenFileName( _
Title:="Please select any file from the folder that contains the files to be updated, then click Open.")
For j = Len(TheFileName) To 1 Step -1
If Mid(TheFileName, j, 1) = "\" Then Exit For
Next j
TheFilePath = Left(TheFileName, j)
TheFileName = TheFilePath & "*.xls"
f = Dir(TheFileName, vbNormal)
Do Until f = ""
x = x + 1
ReDim Preserve FileNameArray(1 To x)
If f <> ThisWorkbook.Name Then 'Don't update the calling workbook
FileNameArray(x) = f 'Return the file name
End If
f = Dir
Loop
GetTheFileNameArray = FileNameArray
End Function
Sub DeleteAllVBA()
Dim VBComp As VBIDE.VBComponent, VBCompTest As VBIDE.VBComponent
Dim VBComps As VBIDE.VBComponents
Set VBComps = ActiveWorkbook.VBProject.VBComponents
For Each VBComp In VBComps
Select Case VBComp.Type
Case vbext_ct_StdModule, vbext_ct_MSForm, _
vbext_ct_ClassModule
'MsgBox "The module name to delete is " & VBComp.Name & " Workbook is " & ActiveWorkbook.Name
VBComps.Remove VBComp
Case Else
'MsgBox "The module name to delete is " & VBComp.Name & " Workbook is " & ActiveWorkbook.Name
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VBComp
End Sub
Sub CopyAllModules(SelectedFile As Variant)
Dim FName As String, ClsFName As String
Dim VBComp As VBIDE.VBComponent
With Workbooks(ThisWorkbook.Name)
FName = .Path & "\code.txt"
If Dir(FName) <> "" Then
Kill FName
End If
For Each VBComp In .VBProject.VBComponents
If VBComp.Type <> vbext_ct_Document Then
VBComp.Export FName
'MsgBox "VBComp name is in Type Not vbext_ct_Document " & VBComp.Name & " VBComp.Type is " & VBComp.Type
Workbooks(SelectedFile).VBProject.VBComponents.Import FName
Kill FName
'Else
' ClsFName = VBComp.Name & ".txt"
' If Dir(ClsFName) <> "" Then
' Kill ClsFName
' End If
' VBComp.Export VBComp.Name & ".txt"
'If ClsFName = "ThisWorkbook" Then
' InsertProcedureCodeFromCode Workbooks(SelectedFile), VBComp.Name, .Path & "\" & ClsFName
' MsgBox "VBComp name is in Type vbext_ct_Document " & VBComp.Name & " VBComp.Type is " & VBComp.Type
' Kill ClsFName
'End If
End If
Next VBComp
End With
End Sub
Please help.
Thank you.
-