Excel with ActiveX controls failing with multiple VBA errors mostly 32809

Related to this sort of MS Security update:

http://support.microsoft.com/kb/3025036/EN-US

This worked for us:

  1. Open a blank version of excel.
  2. Disable ActiveX controls in Excel Options.

excel_disable_activex

  1. Open the offending file. (Click through any error received upon open)
  2. Save the file as a new name.
  3. Activate ActiveX controls.

So saving file without ActiveX enabled does something? anyway worked for us.

Excel VBA from shell command line

Dim objXL
Dim wsSheet
'-- The full path to the template file must be provided in the command line
'-- level eg c:\Temp\_excel> npfmacro.vbs c:\temp\_excel\npftemplate.xlsm
'-- where the npfmacro.vbs is located in the directory c:\temp\_excel
'-- the npftemplate.xlsm has a macro in the module called npf_errorasses which is 
'-- looking for a file called batch.xlsx to act upon.
On Error Resume Next
If WScript.Arguments.Count = 1 Then 
Set objXL = CreateObject("Excel.Application")
With objXL
 .Workbooks.Open (WScript.Arguments.Item(0))
 Set wsSheet = objXL.ActiveWorkbook.Worksheets(2)
 On Error GoTo 0
 If IsObject(wsSheet) Then
 .Application.Run "npf_errorasses"
 Else
 .Application.Run "npf_errorasses"
 End If
 .Application.Quit
End With
Set objXL = Nothing 
END If

Desktop VBS to rename files

Drop into target folder and execute

option explicit

Dim fso, folder, file
Dim sCurPath, sExtension
Dim sOldTargetEnv 
Dim sNewTargetEnv
Dim sNewName

' Where are we
sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")

' Confirm path & get prefix
sOldTargetEnv = InputBox("Enter substring to replace e.g. PROD")
sNewTargetEnv = InputBox("Enter replacement substring e.g. TEST")

if sOldTargetEnv <> "" and sNewTargetEnv <> "" then

    set fso = CreateObject("Scripting.FileSystemObject")
    set folder = fso.GetFolder(sCurPath)
    For Each file In folder.Files

 sExtension = fso.GetExtensionName(file.Name)
 ' Ignore this vbs file
 if ucase(sExtension) <> "VBS" then
  sNewName = Replace(file.Name, sOldTargetEnv , sNewTargetEnv )
  ' Do the rename
         fso.MoveFile file.Name, sNewName
 end if
    Next

    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing

end if

Personal VBA

Lost old Personal.. so starting to collect new one..

Private Sub BorderRowOnTop(row As Long)

    With ActiveSheet.Rows(row).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
   
End Sub


Private Sub ColourRow(row As Integer, colourSet1 As Boolean, inSelectionOnly As Boolean)

    Dim r As Range
    If inSelectionOnly Then
        Set r = ActiveSheet.Range(ActiveSheet.Cells(row, Selection.Column), ActiveSheet.Cells(row, Selection.Columns(Selection.Columns.Count).Column))
    Else
        Set r = ActiveSheet.Rows(row)
    End If

    With r.Interior
        If colourSet1 Then
            If row Mod 2 = 0 Then
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            Else
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End If
        Else
            If row Mod 2 = 0 Then
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            Else
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent3
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End If
        End If
    End With
End Sub


Sub BorderRowsOnChange()

'   For a selected column, border rows when data changes

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    
    Set sel = Selection
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    val = Selection(1, 1).Value
    
    For Each c In sel
        If c.Value <> val Then
            val = c.Value
            BorderRowOnTop (c.row)
        End If
    Next c

End Sub

Sub ColourRowsInSelectionOnlyOnChangeInActiveColumn()

'   For a selected column, alternate coloured rows when data changes
'   Only alternate within selected range

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    Dim colourSet1 As Boolean
    
    Set sel = Selection
    colourSet1 = True
    colourSubSet1 = True
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    
    val = ActiveCell.Value
    Call ColourRow(ActiveCell.row, colourSet1, True)
    
    For Each c In sel
        If c.Value <> val And c.Column = ActiveCell.Column Then
            val = c.Value
            colourSet1 = Not (colourSet1)
        End If
        Call ColourRow(c.row, colourSet1, True)
    Next c

End Sub

Sub ColourCompleteRowsOnChange()

'   For a selected column, alternate coloured rows when data changes

    Dim c As Range
    Dim sel As Range
    
    Dim val As String
    Dim colourSet1 As Boolean
    
    Set sel = Selection
    colourSet1 = True
    colourSubSet1 = True
    
    ' Border top row
    BorderRowOnTop (Selection.row)
    ' Get initial value
    
    val = Selection(1, 1).Value
    
    For Each c In sel
        If c.Value <> val Then
            val = c.Value
            colourSet1 = Not (colourSet1)
        End If
        Call ColourRow(c.row, colourSet1, False)
    Next c

End Sub


 

MS Excel custom function generate random strings

Pinched from someone else, (needs additional character sets, e.g. mixed case, text & numbers)

    Dim Rand As String
    Dim i As Integer, RndNo As Integer, XSet As Integer
    Dim MyCase As Integer
     
    Application.Volatile
    Select Case MySet
    Case Is = "1" 'Upper case
        MyCase = 65: XSet = 26
    Case Is = "2" 'Lower Case
        MyCase = 97: XSet = 26
    Case Is = "3" 'Leading Capital
        MyCase = 97: XSet = 26
    Case Is = "4" 'Text digits
        MyCase = 48: XSet = 10
    Case Is = "5" 'Numeric digits
        MyCase = 48: XSet = 10
    End Select
     
    If MySet = 3 Then 'Set leading character of "Name"
        i = i + 1
        Randomize
        Rand = Rand & Chr(Int((26) * Rnd + 65))
    End If
     'Set random length of string
    RndNo = Int((MaxLen + 1 - MinLen) * Rnd + MinLen)
    Do
        i = i + 1
        Randomize
        Rand = Rand & Chr(Int((XSet) * Rnd + MyCase))
    Loop Until i = RndNo
    RandomString = Rand
     'Convert string to number
    If MySet = 5 Then RandomString = RandomString * 1
     
End Function

 

Collections object in MS Excel

20150304 Revising a complex test data generator worksheet with VBA scripts

I have hidden ranges that specify interaction options for matched rows in the data entry area. I need to increase speed when referencing this range for each row so looking at options for reading and accessing it in memory.  Previous script was for each cell in the data entry area individually finding the reference cell in the table .

Was interested in trying to implement something in excel similar to the Javascript JSON object..  I could just use an array but this is more interesting and allows me to use meanignful keys to identify the elements.

Heres initial implementations of Excel classes using collections of collections just for fun.


2 Levels


Option Explicit

' CollectionsX2
' Collection of collections

' Remember: if you use a number as a key, it must be stringified beforehand else it will be treated an an index

Private ThisCollection As New Collection

Private Function CollectionContains(col As Collection, key As Variant) As Boolean
' As the returned element can be either a object or a descrete variable here is a working solution:
' thanks to http://stackoverflow.com/questions/40651/check-if-a-record-exists-in-a-vb6-collection
    
    On Error Resume Next
    col.Item key
    CollectionContains = (err.Number = 0)
    err.Clear

End Function


Sub SetValue(key1, key2, value)

    key1 = UCase(key1)
    key2 = UCase(key2)

    Dim collection2 As Collection
    
    ' Does element key1 exist in our top level collection?
    If Not CollectionContains(ThisCollection, key1) Then
        ' key1 does not exist
        Set collection2 = New Collection
        Call ThisCollection.ADD(collection2, key1)
    End If
    
    Set collection2 = ThisCollection.Item(key1)
    
    ' Does element key2 exist in our second level collection?
    If CollectionContains(collection2, key2) Then
        collection2.REMOVE key2
    End If
    
    ' Add key2/Value
    Call collection2.ADD(value, key2)
    
End Sub


Function GetValue(key1, key2, valueToReturnIfNotFound)

    key1 = UCase(key1)
    key2 = UCase(key2)

    Dim collection2 As Collection
    
    GetValue = valueToReturnIfNotFound

    ' Does element key1 exist in our top level collection?
    If CollectionContains(ThisCollection, key1) Then
        Set collection2 = ThisCollection(key1)
        ' Does element key2 exist in our second level collection?
        If CollectionContains(collection2, key2) Then
            GetValue = collection2(key2)
        End If
    End If

End Function

Function ElementExistsForKey1Key2(key1 As String, key2 As String) As Boolean

    key1 = UCase(key1)
    key2 = UCase(key2)

    ElementExistsForKey1Key2 = False
    
    Dim collection2 As Collection

    ' Does element keyPri exist in our top level collection?
    If CollectionContains(ThisCollection, key1) Then
        Set collection2 = ThisCollection(key1)
        If CollectionContains(collection2, key2) Then
            ElementExistsForKey1Key2 = True
        End If
    End If

End Function

And I also had a need for a collection of collections of collections.. whoa stop now

Option Explicit

' CollectionsX3
' Collection of collections of collections

' Remember: if you use a number as a key, it must be stringified beforehand else it will be treated an an index

Private ThisCollection As New Collection

Function CollectionContains(col As Collection, key As Variant) As Boolean
' As the returned element can be either a object or a descrete variable here is a working solution:
' thanks to http://stackoverflow.com/questions/40651/check-if-a-record-exists-in-a-vb6-collection
    
    On Error Resume Next
    col.Item key
    CollectionContains = (err.Number = 0)
    err.Clear

End Function


Sub SetValue(key1 As String, key2 As String, key3 As String, value)

    key1 = UCase(key1)
    key2 = UCase(key2)
    key3 = UCase(key3)

    Dim collection2 As Collection
    Dim collection3 As Collection
    
    ' Does element key1 exist in our top level collection?
    If Not CollectionContains(ThisCollection, key1) Then
        ' Key1 does not exist
        Set collection2 = New Collection
        Call ThisCollection.ADD(collection2, key1)
    End If
    
    Set collection2 = ThisCollection.Item(key1)
    
    ' Does element key2 exist in our second level collection?
    If Not CollectionContains(collection2, key2) Then
        ' Key2 does not exist
        Set collection3 = New Collection
        Call collection2.ADD(collection3, key2)
    End If
    
    Set collection3 = collection2.Item(key2)
    
    ' Does element key3 exist in our third level collection?
    If CollectionContains(collection3, key3) Then
        collection3.REMOVE key3
    End If
    
    ' Add keySec/Value
    Call collection3.ADD(value, key3)
    
End Sub


Function GetValue(key1 As String, key2 As String, key3 As String, valueToReturnIfNotFound) As Variant

    key1 = UCase(key1)
    key2 = UCase(key2)
    key3 = UCase(key3)

    ' returns null if no found

    Dim collection2 As Collection
    Dim collection3 As Collection
    
    GetValue = valueToReturnIfNotFound

    ' Does element keyPri exist in our top level collection?
    If CollectionContains(ThisCollection, key1) Then
        Set collection2 = ThisCollection(key1)
        If CollectionContains(collection2, key2) Then
            Set collection3 = collection2(key2)
            ' Does element key3 exist in our third level collection?
            If CollectionContains(collection3, key3) Then
                GetValue = collection3(key3)
            End If
        End If
    End If

End Function

Function ElementExistsForKey1Key2(key1 As String, key2 As String) As Boolean

    key1 = UCase(key1)
    key2 = UCase(key2)

    ElementExistsForKey1Key2 = False
    
    Dim collection2 As Collection

    ' Does element keyPri exist in our top level collection?
    If CollectionContains(ThisCollection, key1) Then
        Set collection2 = ThisCollection(key1)
        If CollectionContains(collection2, key2) Then
            ElementExistsForKey1Key2 = True
        End If
    End If

End Function

Function ElementExistsForKey1Key2Key3(key1 As String, key2 As String, key3 As String) As Boolean

    key1 = UCase(key1)
    key2 = UCase(key2)
    key3 = UCase(key3)

    ElementExistsForKey1Key2Key3 = False
    
    Dim collection2 As Collection
    Dim collection3 As Collection

    ' Does element keyPri exist in our top level collection?
    If CollectionContains(ThisCollection, key1) Then
        Set collection2 = ThisCollection(key1)
        If CollectionContains(collection2, key2) Then
            Set collection3 = collection2(key2)
            If CollectionContains(collection3, key3) Then
                ElementExistsForKey1Key2Key3 = True
            End If
        End If
    End If

End Function

 

 

 

Posted in VBA