Running SAME Excel macro with VBScript

[feriba]

Hi everyone!

After searching the newsgroup, I am still not sure if I can run a local
macro over hundreads of other Excel files. Here are more infos:

I need to code a vbscript that will open an Excel file containing
data(from our sql server) and execute a macro on that Excel file. The
macro is in a local Excel file. Once the macro is done, I need to save
the new Excel file under the same name. I can't really add the macro on
each data files... we have far too many.

Here is what a got so far...

Set xlApp = CreateObject("excel.application")
xlApp.Visible = True
xlApp.Workbooks.Open ("c:\Book1.xls")
xlApp.run "C:\AddressMacro.xls!ModifyPostalCode"
xlApp.Workbooks.save("c:\Book1.xls")

Now I am pretty sure the Macro won't run on Book1xls... How do I
associate it?

Please help!

 

[Bernie Deitrick]

For specific help, post your code for ModifyPostalCode - You'll just need to modify any sheet and
range references within that macro to apply to the activeworkbook.

But here's an example of a macro run from within an Excel workbook - This will act on all workbooks
in the "LookIn" folder:

Sub RunMacroOnAllFilesInFolder()
With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\USERNAME\My Documents\Excel"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
'Put your recurring macro code here, written to act on the activeworkbook
ActiveWorkbook.Close True
Next i
End If
End With
End Sub


HTH,
Bernie
MS Excel MVP

 

[feriba]

Thanks Bernie,

Here is my macro code:

Sub ModifyPostalCode()

Dim i As Integer
Dim cel As Range
Dim lastRow As Integer



'First fix the Postal Codes

Range("AA2").End(xlDown).Select
lastRow = ActiveCell.Row

Range("AA2").Select
Set cel = ActiveCell

For i = 1 To lastRow - 1

If Cells(i + 1, 26).Value = "CANADA" And Len(cel(i).Value) < 7
Then
cel(i).Value = Mid(cel(i).Value, 1, 3) & " " &
Mid(cel(i).Value, 4, 3)
End If

If Len(cel(i).Value) < 5 Then
cel(i).Value = "*0" & StrConv(cel(i).Value, vbUpperCase)
Else
cel(i).Value = "*" & StrConv(cel(i).Value, vbUpperCase)
End If

cel(i).Value = Replace(cel(i).Value, "-", " ")

Next i


Range("AH2").End(xlDown).Select
lastRow = ActiveCell.Row

Range("AH2").Select
Set cel = ActiveCell

For i = 1 To lastRow - 1

If Cells(i + 1, 26).Value = "CANADA" And Len(cel(i).Value) < 7
Then
cel(i).Value = Mid(cel(i).Value, 1, 3) & " " &
Mid(cel(i).Value, 4, 3)
End If


If Len(cel(i).Value) < 5 Then
cel(i).Value = "*0" & StrConv(cel(i).Value, vbUpperCase)
Else
cel(i).Value = "*" & StrConv(cel(i).Value, vbUpperCase)
End If

cel(i).Value = Replace(cel(i).Value, "-", " ")

Next i





'Now sort the data --------------------------------------------

'first create the heading for AX2
Cells(1, 50).Value = "Sort Order"


'first assign the initial catagory without the additional
considerations

Range("U2").End(xlDown).Select
lastRow = ActiveCell.Row

Range("U2").Select
Set cel = ActiveCell

For i = 1 To lastRow - 1
If cel(i).Value = "ED" Or cel(i).Value = "DH" Or cel(i).Value =
"HD" Or cel(i).Value = "EG" Or cel(i).Value = "EH" Then
Cells(i + 1, 50).Value = "1"
ElseIf cel(i).Value = "ZZ" Then
Cells(i + 1, 50).Value = "3"
ElseIf cel(i).Value = "" Then
Cells(i + 1, 50).Value = "4"
Else
Cells(i + 1, 50).Value = "2"
End If


'Now fix layout for Number of Faces considerations
If (cel(i).Value = "EG" Or cel(i).Value = "EH") And Cells(i +
1, 9) > 2 Then
Cells(i + 1, 50).Value = "2"
End If



Next i


'Now sort based on Category Number (AR2 is the Sort By field)

Cells.Select
Range("AH1").Activate
Selection.Sort Key1:=Range("AX2"), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

''Now delete the field AX2
Columns("AX:AX").Select
Selection.ClearContents
Range("AX2").Select



'Update Order Number

Columns("D").Select
Selection.NumberFormat = "0"





End Sub

 

[Bernie Deitrick]

You should be able to do this: put this into the same module as ModifyPostalCode. It will be slow,
and you may need to turn events off (if you are using events) and calculation to manual (if you have
formulas), but otherwise, it should work.

Sub RunMacroOnAllFilesInFolder()
With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\USERNAME\My Documents\Excel"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
ModifyPostalCode
ActiveWorkbook.Close True
Next i
End If
End With
End Sub

 

[feriba]

Thanks Bernie!

I am trying this approch, but I get "Overflow" error at line VBProject.

Sub AddNewMacroToExcel(FileName)
Dim PathMacro, objXL, Workbook, Macros

PathMacro = "C:\MacroModifyPostal.txt"

Set objXL = CreateObject("Excel.Application")

Set Workbook = objXL.Workbooks.Open(FileName)
'objXL.visible = true
'Add ref to macro position
Set Macros =
Workbook.VBProject.VBComponents("ModifyPostalCode").CodeModule
'Add new macro; AddFromFile is also an option
Macros.AddFromFile PathMacro


'Call the new macro
WorkBook.ModifyPostalCode()


' Save the result
ObjXL.Save
Set ObjXL = Nothing
End Sub

AddNewMacroToExcel "C:\Book1.xls"

 

[Bernie Deitrick]

First a note: I have never had consistent success with code that modifies codemodules: often, Excel
will become corrupted and crash when you try this.

Anyway, this section of your code

VBComponents("ModifyPostalCode")

needs to have the module name, not the macro name. And if those two names are the same, change one.
You should never have two things with the same name...

HTH,
Bernie
MS Excel MVP