Remove all Non-AlphaNumeric Characters Including Spaces and Periods

Here's a follow-up on the Tip of the Night for November 23, 2020, which discussed how to remove non-alphanumeric characters from a cell in Excel. The vba code posted below, available here, will also remove all spaces and periods from the cell. See the comparison of the results in this screen grab, with the results for the below function on in cell B2.

The name of the formula is AlphaNumericOnly. As always, open Visual Basic by pressing ALT + F11, and then insert the vba code in a module by selecting the workbook in the project list on the left, and right clicking on Insert . . . Module.

Function AlphaNumericOnly(strSource As String) As StringDim i As IntegerDim strResult As StringFor i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End SelectNext
    AlphaNumericOnly = strResult
End Function

Password Protect Multiple Excel files

You can use the below vba code (posted here by Justin Hampton) to add a password to multiple Excel files in a single folder.

Open a blank workbook, and press ALT + F11. Enter the below visual basic code in a new module, by right clicking on the workbook name in the Project List, and selecting Insert . . . Module

Specify the directory containing your files on the line beginning 'folderPath'.

Enter a password on the line beginning 'Filename:=Application.'.

Run the macro and the files will be protected. When they are next opened, the user will be prompted to enter a password.

As always, I tested this technique tonight using test data, and confirmed that it works.

Public Sub addPassword()
    Dim FSO As Object
    Dim folder As Object, subfolder As Object
    Dim wb As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    'update the path where the files are saved below
    folderPath = "C:\foofolder\test4"
    Set folder = FSO.GetFolder(folderPath)
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
        
    For Each wb In folder.Files
        If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
            Set masterWB = Workbooks.Open(wb)
            'update "yourpassword" to the password you would like to use, below
            ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.FullName, Password:="DogCat2020"
            ActiveWorkbook.Close True
        End If
    Next
    For Each subfolder In folder.SubFolders
        For Each wb In subfolder.Files
            If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
                Set masterWB = Workbooks.Open(wb)
                'update "yourpassword" to the password you would like to use, below
                ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.FullName, Password:="yourpassword"
                ActiveWorkbook.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub

Compare Excel spreadsheets for differences

You can use the below visual basic code (in two modules) to check to see if two worksheets in the same spreadsheet have any text that differs. See the post with this code here.

In Excel, press ALT + F11 to enter Visual Basic and enter the Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet) code in the first module, and the Sub TestCompareWorksheets() code in a second module.

The code is set to review sheets named, 'Sheet1' and 'Sheet2'.

Run the code in the second module, and it will create a new workbook which will show the cells containing different text, with an arrow showing the change from Sheet1 to Sheet2.

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)

Dim r As Long, c As Integer

Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer

Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String

Dim rptWB As Workbook, DiffCount As Long

Application.ScreenUpdating = False

Application.StatusBar = "Creating the report..."

Set rptWB = Workbooks.Add

Application.DisplayAlerts = False

While Worksheets.Count > 1

Worksheets(2).Delete

Wend

Application.DisplayAlerts = True

With ws1.UsedRange

lr1 = .Rows.Count

lc1 = .Columns.Count

End With

With ws2.UsedRange

lr2 = .Rows.Count

lc2 = .Columns.Count

End With

maxR = lr1

maxC = lc1

If maxR < lr2 Then maxR = lr2

If maxC < lc2 Then maxC = lc2

DiffCount = 0

For c = 1 To maxC

Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."

For r = 1 To maxR

cf1 = ""

cf2 = ""

On Error Resume Next

cf1 = ws1.Cells(r, c).FormulaLocal

cf2 = ws2.Cells(r, c).FormulaLocal

On Error GoTo 0

If cf1 <> cf2 Then

DiffCount = DiffCount + 1

Cells(r, c).Formula = "'" & cf1 & " <> " & cf2

End If

Next r

Next c

Application.StatusBar = "Formatting the report..."

With Range(Cells(1, 1), Cells(maxR, maxC))

.Interior.ColorIndex = 19

With .Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

With .Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

With .Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

With .Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

On Error Resume Next

With .Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

With .Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlHairline

End With

On Error GoTo 0

End With

Columns("A:IV").ColumnWidth = 20

rptWB.Saved = True

If DiffCount = 0 Then

rptWB.Close False

End If

Set rptWB = Nothing

Application.StatusBar = False

Application.ScreenUpdating = True

MsgBox DiffCount & " cells contain different formulas!", vbInformation, _

"Compare " & ws1.Name & " with " & ws2.Name

End Sub

Sub TestCompareWorksheets()

' compare two different worksheets in the active workbook

CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")

' compare two different worksheets in two different workbooks

CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _

Workbooks("WorkBookName.xls").Worksheets("Sheet2")

End Sub