Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

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

Posted on 2016-08-14
17
Medium Priority
?
53 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 5
17 Comments
 

Author Comment

by:Brent Guttmann
ID: 41755523
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 49

Expert Comment

by:Martin Liss
ID: 41755678
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
ID: 41755684
Alright, I can work with that.. it was worth asking though.
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LVL 49

Expert Comment

by:Martin Liss
ID: 41755713
Can you supply a sample workbook?
0
 

Author Comment

by:Brent Guttmann
ID: 41755724
let me see... would take some heavy editing.
0
 

Author Comment

by:Brent Guttmann
ID: 41755729
Okay, here you go.
EXAMPLE_FILE_1.xls
0
 
LVL 49

Expert Comment

by:Martin Liss
ID: 41755850
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
 

Author Comment

by:Brent Guttmann
ID: 41755919
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
ID: 41757265
Any luck with the next pieces?
0
 

Accepted Solution

by:
Brent Guttmann earned 0 total points (awarded by participants)
ID: 41757334
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
ID: 41757364
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 49

Expert Comment

by:Martin Liss
ID: 41758713
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
ID: 41758788
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 49

Expert Comment

by:Martin Liss
ID: 41758850
Moderator, please ignore my objection.
0

Featured Post

Enroll in October's Free Course of the Month

Do you work with and analyze data? Enroll in October's Course of the Month for 7+ hours of SQL training, allowing you to quickly and efficiently store or retrieve data. It's free for Premium Members, Team Accounts, and Qualified Experts!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article shows how to deploy dynamic backgrounds to computers depending on the aspect ratio of display
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

604 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