• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 46
  • Last Modified:

Excel vba to highlght certain text, change background color to black, and print to .pdf with all columns fitting on 1 page

Hi, I am trying to accomplish the following:

1. Unlock excel documents and allow them to be editable
2. Find text "Account:" and then move one cell to the right.
3. Within that cell, turn the background of the text to black **except for the last 4 digits of the number
4. Print to .pdf with all columns fitting on 1 page, in landscape view. (number of pages doesnt matter)

If its not possible to unlock the excel doc, is it possible to identify where the target area (the number where we are changing the background to black for all but the last 4 digits) using search, and then adding a black area over it? (I have Nitro Pro) - so maybe could still search the .pdf since it is being created from an excel doc?
0
Brent Guttmann
Asked:
Brent Guttmann
  • 6
1 Solution
 
Robberbaron (robr)Commented:
1/ depends upon how the excel workbook was locked. do you know the password ? if so, you can open the file using the password.,

2. macro recorder is your friend....  the search can be done and I had to test the changing character color myself as i dint know how,
    With ActiveCell.Characters(Start:=4, Length:=5).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16776961
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

Open in new window

0
 
Brent GuttmannAuthor Commented:
Okay, so it looks like it will allow me to edit the text in the document but not change the background color. So, instead of changing the background color for all but the last 4 digits, i'd like to replace each character with an X.

So, lets say the cell to the right of the cell with text "Account" is "123456789", I would want it to be changed to "XXXXX6789"

Also, for the printing part of this, it looks like the vba is going to have to include a count of the number of rows and columns prior to printing to pdf... i've attached the macro recording... it probably only needs to be a handful of those lines but would differ to you as to which.
example.txt
0
 
Brent GuttmannAuthor Commented:
Here is where I am at with it when I was thinking it through...

Sub Test()
Cells.Find(What:="account:", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 1).Select
        With ActiveCell.                    'Here is where i need to count number of characters and replace all but last 4 with Bold X's.

'Thinking the below is starting on the right track...

Dim strNumbers As String
Dim lngNumberOfCharacters As Long
Dim lngXrange As Long
strNumbers = Text(Active.Cell)
lngNumberOfCharacters = Len(strNumbers)
lngXrange = strNumbers - 4    '???

Open in new window

0
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Brent GuttmannAuthor Commented:
Good news, I got it to work. Just need any input you may have for the last piece, the print to pdf

Sub Test()
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
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
For Each cell In rng.Cells
StringLength = Len(cell.Value)
SymbolString = Application.WorksheetFunction.Rept(RedactChar, StringLength - ShowChars)
    If StringLength > ShowChars _
        Then cell.Value = SymbolString & Right(cell.Value, ShowChars)
    Next cell
End Sub

Open in new window

0
 
Brent GuttmannAuthor Commented:
So, I chipped away at it again... but, I am having some problems with the print to .pdf - what its doing is saving as a 55 page document (even though its only like 2-3) and the the formatting is all different, its much smaller font and its off center... so, im sure there is something obvious that I am doing wrong there - any help with that, please???

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
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
 
Brent GuttmannAuthor Commented:
Oh - and the top 20 rows or so (it may vary between documents) are frozen and appear as a header for each printed page.
0
 
Brent GuttmannAuthor Commented:
I figured it out.
0

Featured Post

The 14th Annual Expert Award Winners

The results are in! Meet the top members of our 2017 Expert Awards. Congratulations to all who qualified!

  • 6
Tackle projects and never again get stuck behind a technical roadblock.
Join Now