Solved

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

Posted on 2016-08-14
17
21 Views
Last Modified: 2016-09-23
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

0
Comment
Question by:Brent Guttmann
  • 9
  • 5
17 Comments
 

Author Comment

by:Brent Guttmann
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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.
0
 

Author Comment

by:Brent Guttmann
Comment Utility
Alright, I can work with that.. it was worth asking though.
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
Can you supply a sample workbook?
0
 

Author Comment

by:Brent Guttmann
Comment Utility
let me see... would take some heavy editing.
0
 

Author Comment

by:Brent Guttmann
Comment Utility
Okay, here you go.
EXAMPLE_FILE_1.xls
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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

0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:Brent Guttmann
Comment Utility
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

0
 

Author Comment

by:Brent Guttmann
Comment Utility
Any luck with the next pieces?
0
 

Accepted Solution

by:
Brent Guttmann earned 0 total points (awarded by participants)
Comment Utility
Soo, I worked on this some more and got it looping....

Sub ProcessFiles()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.PrintCommunication = False
    Application.Calculation = xlCalculationManual
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim fileWOext As String
    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 rngFound1 As Range
    Dim rngFound2 As Range
    Dim ShowChars As Integer
    Dim RedactChar As String
    Dim RedactString As String
    Dim StringLength As Long
    Dim RedactEnd As Boolean
    Dim myFileName As String
        RedactEnd = True
        ShowChars = 4
        RedactChar = "X"
        myPath = "C:\temp\test\"
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
  myExtension = "*.xls*"
  myFile = Dir(myPath & myExtension)
    Do While myFile <> ""
        Set wb = Workbooks.Open(FileName:=myPath & myFile)
            fileWOext = Left(wb.Name, InStr(wb.Name, ".") - 1)
            OutputName = "C:\Temp\test\Output\" & fileWOext & " - Redacted"
        myFileName = myPath & myFile
        Set FullRange = wb.Sheets(1).UsedRange
            With FullRange
                LR = .Rows(.Rows.Count).Row
                LC = .Columns(.Columns.Count).Column
                myCol = GetColumnLetter(LC)
            End With
        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
                Set Rng = ActiveCell
                GoTo Redact
            Else
                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
                Set Rng = ActiveCell
                GoTo Redact
Redact:
            Rng.Activate
            With Rng.Cells
                StringLength = Len(Rng.Value)
                SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)
            End With
            If StringLength > ShowChars Then _
                Rng.Value = SymbolString & Right(Rng.Value, ShowChars)
                Rng.Characters(Start:=1, Length:=StringLength - 4).Font _
                .FontStyle = "Bold"
                With wb.Sheets(1)
                    .ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
                    OutputName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                    :=False, OpenAfterPublish:=False
                    With .PageSetup
                        .Orientation = xlLandscape
                        .Zoom = False
                        .FitToPagesWide = 1
                        .ScaleWithDocHeaderFooter = True
                        .AlignMarginsHeaderFooter = False
                        .FirstPageNumber = xlAutomatic
                        .Order = xlDownThenOver
                    End With
                End With
            wb.Close SaveChanges:=False
            Kill myFileName
            myFileName = ""
            myFile = Dir
        End If
    End If
Loop
Handler:
    Application.PrintCommunication = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


    Function MoveToException()
        Workbook.SaveAs myPath & "/Exception/" & myExtension
    Kill wb
    GoTo NextCode
    End Function

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

0
 

Author Comment

by:Brent Guttmann
Comment Utility
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?
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
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.
0
 

Author Comment

by:Brent Guttmann
Comment Utility
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
0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
Moderator, please ignore my objection.
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Real-time is more about the business, not the technology. In day-to-day life, to make real-time decisions like buying or investing, business needs the latest information(e.g. Gold Rate/Stock Rate). Unlike traditional days, you need not wait for a fe…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now