asked on

Tweaks to an Excel Macro - Currently finds and replaces characters in a string and prints to .pdf

Hi, I put together the below macro that I am using to search for the text "Account:" and then apply X's to all characters except the last 4 in the cell to the right of the one that contains the text "Account:" - Then it prints to .pdf and has all columns on 1 page.

The changes I need to make are:

1. Have it first search for "Account:" and if that is not found, then search for "Account #" and if that is not found, then move the file to an "Exception Folder" (Right now it is only looking for "Account:" and will not move the file if it is not found)

2. I have folder "C:\All Docs\All" Docs where I have a list of excel docs, all formats, so it should be looking for .xls* - I need for this same macro to be ran on all excel docs in the folder.

3. Each output .pdf file should be saved to an output folder and the original excel file should be moved to a "Processed" folder once it has been processed, assuming it should not be moved to the "Exception" folder. Output file = "C:\All Docs\Output" and Processed Folder = "C:\All Docs\Processed"I have the naming convention already set up - should be the same file name with " - Redacted" added to the end

4. I would like for the same logic to to be applied to the document if there are multiple instances of "Account: " or "Account #" - I would prefer search over a loop through each cell because this will be running on a lot of files and run-time is a big factor.

5, I would like to save these .pdfs in a format that is friendly to OCR - I know that some .pdf formats will still allow for searches. If this is going to add a lot of time, then we should skip this as like I said, this program should have a pretty quick run time. But, I was thinking that since its currently in excel format, saving to a searchable .pdf may not take additional time.

Below is macro I am currently using - Thanks for any help!

Sub Test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
On Error GoTo Error
Dim ShowChars As Integer
Dim RedactChar As String
Dim RedactString As String
Dim StringLength As Long
Dim RedactEnd As Boolean
Dim cell As Range
Dim Rng As Range
Dim LastC As String
Dim LastCRange As Range
Dim myCol As String
Dim FullRange As Range
Dim LR As Long
Dim LC As Long
Dim FileName As String
'FileName = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
TestName = "C:\temp\" & ActiveWorkbook.Name & " - Redacted"
Set FullRange = ActiveSheet.UsedRange
    With FullRange
        LR = .Rows(.Rows.Count).Row
        LC = .Columns(.Columns.Count).Column
        myCol = GetColumnLetter(LC)
    End With
RedactEnd = True
ShowChars = 4
RedactChar = "X"
Cells.Find(What:="Account:", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, 1).Select
Set Rng = ActiveCell
    With Rng.Cells
        StringLength = Len(Rng.Value)
        SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)
        If StringLength > ShowChars _
            Then Rng.Value = SymbolString & Right(Rng.Value, ShowChars)
            Rng.Characters(Start:=1, Length:=StringLength - 4).Font _
            .FontStyle = "Bold"
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            TestName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
            With ActiveSheet.PageSetup
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
            End With
        End With
Error:
Application.PrintCommunication = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function

Open in new window

Brent Guttmann

ASKER

One additional add on - I'd like to have this macro converted to an .exe file that can be called from a third party program.

Martin Liss

I'd like to have this macro converted to an .exe file...

I'm not the last word on this but if you are talking about a stand-alone exe then I doubt it can be done. You'd could open the Excel file programmatically and then run the macro.

Brent Guttmann

ASKER

Alright, I can work with that.. it was worth asking though.

Martin Liss

Can you supply a sample workbook?

Brent Guttmann

ASKER

let me see... would take some heavy editing.

Brent Guttmann

ASKER

Okay, here you go.
EXAMPLE_FILE_1.xls

Martin Liss

For #1 try this.

Sub Test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
On Error GoTo Error
Dim ShowChars As Integer
Dim RedactChar As String
Dim RedactString As String
Dim StringLength As Long
Dim RedactEnd As Boolean
Dim cell As Range
Dim Rng As Range
Dim LastC As String
Dim LastCRange As Range
Dim myCol As String
Dim FullRange As Range
Dim LR As Long
Dim LC As Long
Dim FileName As String
'new
Dim rngFound As Range

'FileName = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
TestName = "C:\temp\" & ActiveWorkbook.Name & " - Redacted"
Set FullRange = ActiveSheet.UsedRange
    With FullRange
        LR = .Rows(.Rows.Count).Row
        LC = .Columns(.Columns.Count).Column
        myCol = GetColumnLetter(LC)
    End With
RedactEnd = True
ShowChars = 4
RedactChar = "X"
'new
'Cells.Find(What:="Account:", After:=ActiveCell, LookIn:=xlFormulas, _
'    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'    MatchCase:=False, SearchFormat:=False).Activate
'    ActiveCell.Offset(0, 1).Select
Set rngFound = Cells.Find(What:="Account:", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    ActiveCell.Offset(0, 1).Select
If rngFound Is Nothing Then
    Set rngFound = Cells.Find(What:="Account#", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        ActiveCell.Offset(0, 1).Select
End If
If rngFound Is Nothing Then
    MoveToException
    Exit Sub
End If

Set Rng = ActiveCell
    With Rng.Cells
        StringLength = Len(Rng.Value)
        SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)
        If StringLength > ShowChars _
            Then Rng.Value = SymbolString & Right(Rng.Value, ShowChars)
            Rng.Characters(Start:=1, Length:=StringLength - 4).Font _
            .FontStyle = "Bold"
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            TestName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
            With ActiveSheet.PageSetup
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
            End With
        End With
Error:
Application.PrintCommunication = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Open in new window

Sub MoveToException()
    
    Dim sFileNameExt As String
    Dim sFilePath As String
    Dim sNewPath As String
    
    sNewPath = "C:\Exception\" ' Change as required
 
    sFilePath = ActiveWorkbook.Path
    sFileNameExt = ActiveWorkbook.Name
     
    ActiveWorkbook.SaveAs sNewPath & sFileNameExt
    Kill sFilePath & "\" & sFileNameExt
    
End Sub

Open in new window

Brent Guttmann

ASKER

I made some tweaks - Have it working.

Sub Test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
On Error GoTo Error
Dim ShowChars As Integer
Dim RedactChar As String
Dim RedactString As String
Dim StringLength As Long
Dim RedactEnd As Boolean
Dim cell As Range
Dim Rng As Range
Dim LastC As String
Dim LastCRange As Range
Dim myCol As String
Dim FullRange As Range
Dim LR As Long
Dim LC As Long
Dim FileName As String
Dim TestName As String
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim SymbolString As String
Dim wbName As String
Dim sFileNameExt As String
Dim sFilePath As String
wbName = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
'FileName = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
TestName = "C:\temp\Output\" & wbName & " - Redacted"
Set FullRange = ActiveSheet.UsedRange
    With FullRange
        LR = .Rows(.Rows.Count).Row
        LC = .Columns(.Columns.Count).Column
        myCol = GetColumnLetter(LC)
    End With
RedactEnd = True
ShowChars = 4
RedactChar = "X"
'new
'Cells.Find(What:="Account:", After:=ActiveCell, LookIn:=xlFormulas, _
'    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'    MatchCase:=False, SearchFormat:=False).Activate
'    ActiveCell.Offset(0, 1).Select
FullRange.Select
Set rngFound1 = Selection.Find(What:="Account:", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    If Not (rngFound1 Is Nothing) Then
        rngFound1.Select
        ActiveCell.Offset(0, 1).Select
        Else
            'If rngFound1 Is Nothing Then
                Set rngFound2 = Cells.Find(What:="Account #", After:=ActiveCell, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                If Not (rngFound2 Is Nothing) Then
                    rngFound2.Select
                    ActiveCell.Offset(0, 1).Select
                    Else: MoveToException
                    Exit Sub
                End If
            End If
Set Rng = ActiveCell
    With Rng.Cells
        StringLength = Len(Rng.Value)
        SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)
        If StringLength > ShowChars _
            Then Rng.Value = SymbolString & Right(Rng.Value, ShowChars)
            Rng.Characters(Start:=1, Length:=StringLength - 4).Font _
            .FontStyle = "Bold"
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            TestName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False
            With ActiveSheet.PageSetup
                .Orientation = xlLandscape
                .Zoom = False
                .FitToPagesWide = 1
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
            End With
        End With
sFilePath = ActiveWorkbook.Path
sFileNameExt = ActiveWorkbook.Name
Kill sFilePath & "\" & sFileName
Application.PrintCommunication = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Error:
Application.PrintCommunication = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MoveToException
End Sub

Sub MoveToException()
    
    Dim sFileNameExt As String
    Dim sFilePath As String
    Dim sNewPath As String
    If Error Then GoTo Error
    sNewPath = "C:\Temp\Exceptions\" ' Change as required
 
    sFilePath = ActiveWorkbook.Path
    sFileNameExt = ActiveWorkbook.Name
     
    ActiveWorkbook.SaveAs sNewPath & sFileNameExt
    Kill sFilePath & "\" & sFileNameExt
    Application.PrintCommunication = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function

Open in new window

Brent Guttmann

ASKER

Any luck with the next pieces?

ASKER CERTIFIED SOLUTION

Brent Guttmann

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Brent Guttmann

ASKER

So, it will look through a fair amount but some files are throwing an error at this line:
SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)

The message is : Run-Time error '1004':

Unable to get the Rept property of the WorksheetFunction Class

Any thoughts on how to fix this?

If its unfix-able, which I dont think it is.., how can I add an error catch to move it to the exception folder?

Martin Liss

While I didn't provide an answer to each of the four questions asked, I did provide an answer to the first one, so IMO I should get partial credit.

Brent Guttmann

ASKER

Hey, fine by me. Would have been helpful if you were working through it with me though... objected a lot faster than responding to my messages

Martin Liss

Moderator, please ignore my objection.