Sub ImportModules_4()
Dim objFSO As Object ' FileSystemObject
Dim objFolder As Object ' Folder
Dim f As Object ' File
Dim wb As Workbook
Dim lLRow As Long
Dim lRow As Long
Dim lCurLine As Long
Dim lLineCount As Long
Dim o_CodeModule As Object ' CodeModule
Dim o_vbComponent As Object ' VBComponent
Set objFSO = CreateObject("Scripting.FileSystemObject")
'//TESTING, change path back //
'Set objFolder = objFSO.GetFolder("C:\Module Project\ExcelFiles")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path & "\")
For Each f In objFolder.Files
If Not f.Path = ThisWorkbook.FullName _
And f.Name Like "*.xls*" Then 'Just because I tested in the same folder
Set wb = Workbooks.Open(f.Path, , False)
With wb.VBProject
'// Just in case the CodeName 'Sheet1' does not exist. //
Set o_vbComponent = Nothing
On Error Resume Next
Set o_vbComponent = .VBComponents("Sheet1")
On Error GoTo 0
If Not o_vbComponent Is Nothing Then
Set o_CodeModule = o_vbComponent.CodeModule
o_CodeModule.AddFromString BuildReallyLongString
wb.Close True
Else
MsgBox "Unable to find the CodeName 'Sheet1' in " & wb.Name, 0, ""
wb.Close False
End If
End With
End If
Next
End Sub
Function BuildReallyLongString() As String
Dim a As String
Const z = vbCrLf
Dim x: x = Space(4)
a = x & z
a = a & "Private Sub Worksheet_Change(ByVal Target As Range)" & z
a = a & "Dim KeyCell As Range" & z
a = a & x & z
a = a & " 'The variable KeyCell contains the cell that will cause an alert when it is changed." & z
a = a & " Set KeyCell = Range(""K1"")" & z
a = a & x & z
a = a & " If Not Application.Intersect(KeyCell, Range(Target.Address)) Is Nothing Then" & z
a = a & " FindDuplicate" & z
a = a & " End If" & z
a = a & "End Sub" & z
a = a & x & z
a = a & "Private Sub FindDuplicate()" & z
a = a & "Dim ICCR As String" & z
a = a & "Dim FoundCell As Range" & z
a = a & x & z
a = a & " 'The variable ICCR contains the value that will be searched for" & z
a = a & " ICCR = Range(""K1"").Value" & z
a = a & x & z
a = a & " 'Searches for the contents of the variable ICCR" & z
a = a & " Set FoundCell = Range(""K:K"").Find(What:=ICCR, _" & z
a = a & " After:=Range(""K1""), _" & z
a = a & " LookIn:=xlValues, _" & z
a = a & " LookAt:=xlWhole, _" & z
a = a & " SearchOrder:=xlByRows, _" & z
a = a & " SearchDirection:=xlNext, _" & z
a = a & " MatchCase:=False) ', _" & z
a = a & " SearchFormat:=False) '<-- not in 2000" & z
a = a & x & z
a = a & " 'If the ICCR is not found, display a message box to the user" & z
a = a & " If Not FoundCell Is Nothing Then" & z
a = a & " If FoundCell.Address(0, 0) = ""K1"" Then" & z
a = a & " ActiveSheet.Range(""K1"").Select" & z
a = a & " MsgBox ""ICCR "" & Range(""K1"") & "" Not Found""" & z
a = a & " Exit Sub" & z
a = a & x & z
a = a & " 'If the ICCR is found, highlight the corresponding row" & z
a = a & " Else" & z
a = a & " Rows(FoundCell.Row).Select" & z
a = a & " End If" & z
a = a & " Else" & z
a = a & " ActiveSheet.Range(""K1"").Select" & z
a = a & " MsgBox ""ICCR "" & Range(""K1"") & "" Not Found""" & z
a = a & " Exit Sub" & z
a = a & " End If" & z
a = a & "End Sub" & z
Dim i As Long
For i = 1 To 355
a = a & " 'Here's a bunch of bogus commenting inserted just to suck up length, to see if we can still grab all in one shot, when sending the text to write another file blah blah balh..." & z
Next
MsgBox Len(a)
BuildReallyLongString = a
End Function