macro to add text to existing text and not overwrite

bmkelly · Feb 3, 2022

Hello, I am trying to have my notes add to existing notes instead of overwriting what is already there (whether the notes are manually typed in or from the macro). Below is what I am looking for in regards to each note to be added. An individual helped me with the "Blank Warranty Addition" Note where it adds on to existing notes but I would like to incorporate that into the others.

Here is my Macro

VBA Code:

Sub MyPricing()

Application.ScreenUpdating = False

'Insert Analyst Notes, Site Manager Notes and Corrections Column'
    Dim rngUsernameHeader As Range
    Dim rngHeaders As Range

    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="BDS Unit Price", After:=Cells(1, 1))

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Analyst Notes"
        
    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="Analyst Notes", After:=Cells(1, 1))

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Site Manager Notes"
    
    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="Site Manager Notes", After:=Cells(1, 1))

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Corrections"

'Highlighting Columns'
    Range("Table1[[#Headers],[Analyst Notes]:[Corrections]]").Select
    Range(Selection, Selection.End(xlDown)).Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.599993896298105
            .PatternTintAndShade = 0
    
        End With
    
'Format Date'
    hdrs = Array("EnteredDate", "WarrantyEnd", "RetiredDate", "Proration Date", "Charged Date", "InstalledDate", "VendorContractEnd")
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
            heads = Range(Cells(1, 1), Cells(1, LastCol))
 
    For i = 0 To UBound(hdrs)
    For j = 1 To UBound(heads, 2)
        If hdrs(i) = heads(1, j) Then
            Range(Cells(1, j), Cells(LastRow, j)).NumberFormat = "m/d/yyyy"
                Exit For
            End If
        Next j
    Next i
 
'Format Accounting'
    hdrs = Array("BDS Unit Price", "SVC", "Hospital Price", "FRP", "Net_CC_Price", "Eq_Row", "True annual price", "Proration Amount", "Effective Price")
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
            heads = Range(Cells(1, 1), Cells(1, LastCol))
 
    For i = 0 To UBound(hdrs)
    For j = 1 To UBound(heads, 2)
        If hdrs(i) = heads(1, j) Then
            Range(Cells(1, j), Cells(LastRow, j)).Style = "Currency"
                Exit For
            End If
        Next j
    Next i

'Format Width'
    Cells.ColumnWidth = 15

    Range("Table1[[#Headers],[EquipmentID]]").Select

'Reactivations'
    Dim NCol As Range
    
        On Error Resume Next
    
        Set NCol = Range("1:1").Find("Notes", , , xlWhole, , , False, , False)
            If NCol Is Nothing Then
                MsgBox "Notes Column Not Found"
            Exit Sub
        
        End If
   
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
  
        With NCol.EntireColumn
            .Replace "Standard Reactivations", "=true", xlWhole, , False, , False, False
                On Error Resume Next
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Reactivation"
                On Error GoTo 0
            .Replace "=true", "Standard Reactivations", xlWhole, , False, , False, False
    End With

'Proration'
    Dim PCol As Range

        On Error Resume Next
    
        Set PCol = Range("1:1").Find("Proration Date", , , xlWhole, , , False, , False)
            If PCol Is Nothing Then
                MsgBox "Proration Date Column Not Found"
            Exit Sub
        
        End If
        
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
                           
        With Range(PCol.Offset(1), Cells(Rows.Count, PCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - PCol.Column).Value = "Review - Prorate?"
            
        If PCol Is Nothing Then Exit Sub
 
    End With
    
'High Dollar Value'
    Dim BDSCol As Range

        On Error Resume Next

        Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
            If BDSCol Is Nothing Or ANCol Is Nothing Then
                MsgBox "BDS Unit Price Column Not Found"
            Exit Sub
        
        End If
        
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
    
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#>4999,""Review - High Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - ANCol.Column).Address))

    End With

'Low Dollar Value'

        On Error Resume Next

        Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
            If BDSCol Is Nothing Or ANCol Is Nothing Then
                MsgBox "BDS Unit Price Column Not Found"
            Exit Sub
        
        End If
        
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
        
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, SMNCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#<-4999,""Review - Low Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - SMNCol.Column).Address))

    End With
    
'Missing Coverage'
    Dim CCol As Range
  
        On Error Resume Next

        Set CCol = Range("1:1").Find("Coverage", , , xlWhole, , , False, , False)
            If CCol Is Nothing Then
                MsgBox "Coverage Column Not Found"
            Exit Sub
        
        End If
   
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
  
        With CCol.EntireColumn
            .Replace "Missing Coverage", "=true", xlWhole, , False, , False, False
                On Error Resume Next
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Review - Missing Coverage"
                On Error GoTo 0
            .Replace "=true", "Missing Coverage", xlWhole, , False, , False, False
    End With

'Under Contract'
    Dim VCol As Range
 
        On Error Resume Next

        Set VCol = Range("1:1").Find("VendorContract", , , xlWhole, , , False, , False)
            If VCol Is Nothing Then
                MsgBox "VendorContract Column Not Found"
            Exit Sub
        
        End If
        
        Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
            If ANCol Is Nothing Then
                MsgBox "Analyst Notes Column Not Found"
            Exit Sub
        
        End If
   
        With Range(VCol.Offset(1), Cells(Rows.Count, VCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - VCol.Column).Value = "Review - Contract"
        
    End With

'Blank Warranty Addition'
    Dim TTCol As Range
    Dim WECol As Range
    Dim rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim note As String
    
    note = "Review - Blank Warranty Addition"

        With Sheets("Export Detail")
        
    'TheSheet.Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)'
        Set TTCol = .Range("1:1").Find("Transaction Type", , xlValues, xlWhole)
        Set WECol = .Range("1:1").Find("WarrantyEnd", , xlValues, xlWhole)
        Set ANCol = .Range("1:1").Find("Analyst Notes", , xlValues, xlWhole)

        LR = .Cells(.Rows.Count, TTCol.Column).End(xlUp).Row
    
        Set rng = .Range(.Cells(2, TTCol.Column), .Cells(LR, TTCol.Column))
            For Each cel In rng
                If cel.Value = "Addition" Then
                If .Cells(cel.Row, WECol.Column) = "" Then
            'Insert Note After Existing Note'
                .Cells(cel.Row, ANCol.Column).Value = .Cells(cel.Row, ANCol.Column).Value & " " & note
                
            End If
            
        End If
        
    Next cel
    
End With

'Hiding Columns'
    Dim LastColumn As Long

        LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
            For i = 1 To LastColumn
        If Cells(1, i).Value = "SVC" Or Cells(1, i).Value = "Modality" Or Cells(1, i).Value = "EQStatus" Or Cells(1, i).Value = "Sub Status" Or Cells(1, i).Value = "InstalledDate" Or Cells(1, i).Value = "Ownership" Or Cells(1, i).Value = "WarrantyCode" Or Cells(1, i).Value = "VendorContract" Or Cells(1, i).Value = "VendorContractEnd" Or Cells(1, i).Value = "ServiceStrategyYear1" Or Cells(1, i).Value = "Pricing Method" Or Cells(1, i).Value = "Notes" Or Cells(1, i).Value = "Price_Type" Or Cells(1, i).Value = "Cust_Type" Or Cells(1, i).Value = "Net_CC_Price" Or Cells(1, i).Value = "Eq_Row" Or Cells(1, i).Value = "True annual price" Or Cells(1, i).Value = "Proration Amount" Then Columns(i).Hidden = True
    Next

    'Highlighting Columns'
        Range("Table1[[#Headers],[Analyst Notes]:[Corrections]]").Select
        Range(Selection, Selection.End(xlDown)).Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent2
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
    
    End With
    
'Hide Exceptions'
    Worksheets("Exceptions").Visible = False

'Select Cell A1'
    Range("Table1[[#Headers],[EquipmentID]]").Select

Application.ScreenUpdating = True

End Sub

'Blank Warranty Addition'
need to look down the 'Transaction Type' column, finding the word 'Addition', look to see if the 'WarrantyEnd' cell on that row is blank and if it is, add the note to the 'Site Manager Notes' cell.

'Reactivations'
need to look down the 'Notes' column, find the words Standard Reactivations and then add the note "Reactivation" to the 'Site Manager Notes' cell.

'Proration'
need to look down the 'Proration Date' column, if there is a date in this column then add the note "Review - Prorate?" to the 'Site Manager Notes' cell.

'High Dollar Value'
need to look down the 'BDS Unite Price' column, if the value is above $4,999.00 then add the note "Review - High Dollar Value" to the 'Site Manager Notes' cell.

'Low Dollar Value'
need to look down the 'BDS Unite Price' column, if the value is below -$4,999.00 then add the note "Review - Low Dollar Value" to the 'Site Manager Notes' cell.

'Missing Coverage'
need to look down the 'Coverage' column, find the words "Missing Coverage" and then add the note "Review - Missing Coverage" to the 'Site Manager Notes' cell.

'Under Contract'
need to look down the 'Vendor Contract' column, if there is data in this column then add the note "Review - Contract" to the 'Site Manager Notes' cell.

I feel like most of these would be written a similar fashion, that way when I have or add more automation then I can just take the code and change a few pieces of criteria to match - example: I would like to do something where the code will look down the "Transaction Type" column for "Transfer" and then look down the "Coverage" column for "Missing Coverage or the "Warranty End" column with a blank warranty (blank cell) or the "Vendor Contract" column and if it has a contract then leave the "Site Manager Notes" cell 'Blank'. That is another add on I would like to incorporate but for your sake and sanity we can just focus on the above.

Here is example data of the entire headers of the worksheet:

Test Pricing Doc - Example Data.xlsx

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

AQ

AR

1

EquipmentID

Model_ID

RSQM_CustNmbr

DepartmentID

RSQM_Cust_Name

Department

CEID

Serial

Manufacturer

Model

Description

Coverage

Transaction Type

EnteredDate

WarrantyEnd

RetiredDate

Proration Date

Charged Date

BDS Unit Price

Analyst Notes

Site Manager Notes

Corrections

SVC

Modality

EQStatus

Sub Status

InstalledDate

Ownership

WarrantyCode

VendorContract

VendorContractEnd

QTR Eff

ServiceStrategyYear1

Pricing Method

Notes

Hospital Price

FRP

Price_Type

Cust_Type

Net_CC_Price

Eq_Row

True annual price

Proration Amount

OY22 Impact

2

000000012345678

1234

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

A Department

12345678

A-12345

A Manu

A Model

Test

All Parts & Labor

Coverage Change

10/22/2018

8/20/2021

$ 32,750.00

Review - High Dollar Value

$ 755,509.11

RADIOLOGY

Active

Owned

8/18/2018

OY22-Qtr1

InHouse-Full Service

Coverage Change Delta

Standard Coverage Change

$ 48,250.00

$ 81,000.00

FRP

Oct - Sept

$ 81,000.00

$ -

$ 28,173.97

3

000000023456789

2345

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

B Department

23456789

B-12345

B Manu

B Model

Test

All Parts & Labor

Coverage Change

12/27/2019

12/1/2020

7/1/2021

$ 19,250.00

Review - Prorate? - Review - High Dollar Value

Standard Coverage Change

$ 11,180.82

$ 30,378.08

4

000000034567891

3456

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

C Department

34567891

C-12345

C Manu

C Model

Test

All Parts & Labor

Addition

9/1/2021

$ 6,900.00

Review - High Dollar Value - Review - Blank Warranty Addition

$ 58,602.11

RADIOLOGY

Active

Owned

8/31/2021

OY22-Qtr1

InHouse-Full Service

OY Budget Model Price

Standard Additions

$ 6,900.00

FRP

Oct - Sept

$ -

$ 5,709.04

5

000000045678912

4567

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

D Department

45678912

D-12345

D Manu

D Model

Test

All Parts & Labor

Addition

9/7/2021

$ 6,500.00

Review - High Dollar Value

$ 11,308.18

BIOMED

Active

Owned

9/7/2021

OY22-Qtr1

InHouse-Full Service

Prime Price

Standard Additions

$ 6,500.00

FRP

Oct - Sept

$ -

$ 5,271.23

6

000000056789123

5678

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

E Department

56789123

E-12345

E Manu

E Model

Test

All Parts & Labor

Coverage Change

10/22/2018

7/8/2021

$ 5,940.80

Review - High Dollar Value

$ 31,494.11

BIOMED

Active

Owned

11/19/2015

OY22-Qtr1

InHouse-Full Service

Coverage Change Delta

Standard Coverage Change

$ 2,059.20

$ 8,000.00

FRP

Oct - Sept

$ 8,000.00

$ -

$ 5,810.59

7

000000067891234

6789

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

F Department

67891234

F-12345

F Manu

F Model

Test

Missing Coverage

Addition

8/17/2021

$ 4,998.00

Review - Missing Coverage - Review - Blank Warranty Addition

$ 26,715.18

RADIOLOGY

Active

Owned

8/17/2021

OY22-Qtr1

InHouse-Full Service

Market Price

Standard Additions

$ 5,000.00

FRP

Oct - Sept

$ -

$ 4,342.47

8

000000567891234

7891

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

G Department

567891234

G-12345

G Manu

G Model

Test

Missing Coverage

Coverage Change

10/22/2018

9/20/2021

$ 4,960.00

Review - Missing Coverage - Review - Contract

$ 328,400.18

RADIOLOGY

Active

Owned

1/6/2013

TVC010919

OY22-Qtr1

InHouse-Full Service

Coverage Change Delta

Standard Coverage Change

$ 39,040.00

$ 44,000.00

FRP

Oct - Sept

$ 44,000.00

$ -

$ 3,845.70

9

000000678912345

8912

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

H Department

678912345

H-12345

H Manu

H Model

Test

Missing Coverage

Coverage Change

9/11/2019

1/1/2018

9/20/2021

$ 4,600.00

Review - Missing Coverage

$ 44,875.11

RADIOLOGY

Active

Owned

10/4/2017

OY22-Qtr1

InHouse-Full Service

Coverage Change Delta

Standard Coverage Change

$ -

$ 4,600.00

FRP

Oct - Sept

$ 4,600.00

$ -

$ 3,566.58

10

000000789123456

9123

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

I Department

789123456

I-12345

I Manu

I Model

Test

Missing Coverage

Coverage Change

9/13/2019

9/1/2018

9/20/2021

$ 4,300.00

Review - Missing Coverage

$ 168,317.11

RADIOLOGY

Active

Owned

9/12/2019

OY22-Qtr1

InHouse-Full Service

Coverage Change Delta

Standard Coverage Change

$ -

$ 4,300.00

FRP

Oct - Sept

$ 4,300.00

$ -

$ 3,333.97

11

000000891234567

12345

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

J Department

891234567

J-12345

J Manu

J Model

Test

Missing Coverage

Addition

8/6/2021

$ 2,400.00

Reactivation - Review - Blank Warranty Addition

$ 6,469.11

BIOMED

Active

Owned

8/6/2021

OY22-Qtr1

InHouse-Full Service

Prime Price Desc

Standard Reactivations

$ 2,400.00

FRP

Oct - Sept

$ -

$ 2,156.71

12

000000912345678

23456

ACCT1234567

abcdefghijklmnopqrstuvwxyz

ABC Hospital

K Department

912345678

K-12345

K Manu

K Model

Test

All Parts & Labor

Retirement

8/6/2021

$ (5,555.00)

Review - Low Dollar Value

$ 6,469.11

BIOMED

Active

Owned

8/6/2021

OY22-Qtr1

InHouse-Full Service

Prime Price Desc

Standard Retirements

$ 2,400.00

FRP

Oct - Sept

$ -

$ 2,156.71

Export Detail

Cell Formulas
Range	Formula
AQ2:AQ12	AQ2	=IF([@[Proration Date]]>0,(("6/30/22"-[@[Proration Date]])([@[BDS Unit Price]]/365))-("6/30/22"-[@[Charged Date]])([@[BDS Unit Price]]/365),0)
AR2:AR12	AR2	=("6/30/22"-[@[Charged Date]])*([@[BDS Unit Price]]/365)+[@[Proration Amount]]

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:A195	Cell Value	duplicates	text	NO

shknbk2 · Feb 3, 2022

I tried to genericize adding the notes using a couple of new functions. The AddNotes (this is the one you will want to amend for adding new notes) procedure is hopefully self-explanatory using the comments in the AddNote procedure. You can see that I completed 5 note adds so I could test to see if it works. If you can add the remaining notes without much difficulty in understanding what is going on and without any errors, then the code is successful. Adding a new note is a one-line deal (except if you use line breaks like I did) that avoids the need to repeat copying the same lines of code over and over.

In the code, I used xlFormulas instead of xlValues because I kept getting "not founds" even though the header row matched the text. For some reason, formulas worked where values didn't. Also, when copying your table above, I had to trim extra spaces in the headers so that the Match Entire Contents would work. Your raw data might not suffer from the extra spaces.

Let me know if it is confusing.

VBA Code:

Sub MyPricing()

    Application.ScreenUpdating = False

'Insert Analyst Notes, Site Manager Notes and Corrections Column'
    Dim rngUsernameHeader As Range
    Dim rngHeaders As Range

    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="BDS Unit Price", After:=Cells(1, 1), LookIn:=xlFormulas)

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Analyst Notes"
        
    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="Analyst Notes", After:=Cells(1, 1), LookIn:=xlFormulas)

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Site Manager Notes"
    
    Set rngHeaders = Range("1:1")
    Set rngUsernameHeader = rngHeaders.Find(What:="Site Manager Notes", After:=Cells(1, 1), LookIn:=xlFormulas)

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Corrections"

'Highlighting Columns'
    Range("Table1[[#Headers],[Analyst Notes]:[Corrections]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    
'Format Date'
    Dim hdrs As Variant
    Dim LastCol As Long
    Dim LastRow As Long
    Dim heads As Variant
    Dim i As Integer
    Dim j As Integer
    
    hdrs = Array("EnteredDate", "WarrantyEnd", "RetiredDate", "Proration Date", "Charged Date", "InstalledDate", "VendorContractEnd")
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
            heads = Range(Cells(1, 1), Cells(1, LastCol))
 
    For i = 0 To UBound(hdrs)
        For j = 1 To UBound(heads, 2)
            If hdrs(i) = heads(1, j) Then
                Range(Cells(1, j), Cells(LastRow, j)).NumberFormat = "m/d/yyyy"
                Exit For
            End If
        Next j
    Next i
 
'Format Accounting'
    hdrs = Array("BDS Unit Price", "SVC", "Hospital Price", "FRP", "Net_CC_Price", "Eq_Row", "True annual price", "Proration Amount", "Effective Price")
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    heads = Range(Cells(1, 1), Cells(1, LastCol))
 
    For i = 0 To UBound(hdrs)
        For j = 1 To UBound(heads, 2)
            If hdrs(i) = heads(1, j) Then
                Range(Cells(1, j), Cells(LastRow, j)).Style = "Currency"
                Exit For
            End If
        Next j
    Next i

'Format Width'
    Cells.ColumnWidth = 15

    Range("Table1[[#Headers],[EquipmentID]]").Select

'Add Notes'
    AddNotes

'Hiding Columns'
    Dim LastColumn As Long

    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To LastColumn
        If Cells(1, i).Value = "SVC" Or Cells(1, i).Value = "Modality" Or Cells(1, i).Value = "EQStatus" Or Cells(1, i).Value = "Sub Status" Or Cells(1, i).Value = "InstalledDate" Or Cells(1, i).Value = "Ownership" Or Cells(1, i).Value = "WarrantyCode" Or Cells(1, i).Value = "VendorContract" Or Cells(1, i).Value = "VendorContractEnd" Or Cells(1, i).Value = "ServiceStrategyYear1" Or Cells(1, i).Value = "Pricing Method" Or Cells(1, i).Value = "Notes" Or Cells(1, i).Value = "Price_Type" Or Cells(1, i).Value = "Cust_Type" Or Cells(1, i).Value = "Net_CC_Price" Or Cells(1, i).Value = "Eq_Row" Or Cells(1, i).Value = "True annual price" Or Cells(1, i).Value = "Proration Amount" Then Columns(i).Hidden = True
    Next

    'Highlighting Columns'
    Range("Table1[[#Headers],[Analyst Notes]:[Corrections]]").Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    
'Hide Exceptions'
    Worksheets("Exceptions").Visible = False

'Select Cell A1'
    Range("Table1[[#Headers],[EquipmentID]]").Select

    Application.ScreenUpdating = True

End Sub

Sub AddNotes()
    'Blank Warranty Addition'
    AddNote "Export Detail", "Transaction Type", "=", "Addition", "WarrantyEnd", "=", "", "Site Manager Notes", _
      "Review - Blank Warranty Addition"
    
    'Reactivations'
    AddNote "Export Detail", "Notes", "=", "Standard Reactivations", "", "", "", "Site Manager Notes", _
      "Reactivations"
    
    'Under Contract'
    AddNote "Export Detail", "VendorContract", "<>", "", "", "", "", "Site Manager Notes", _
      "Review - Contract"
    
    'Missing Coverage'
    AddNote "Export Detail", "Coverage", "=", "Missing Coverage", "", "", "", "Site Manager Notes", _
      "Review - Missing Coverage"
    
    'Low Dollar Value'
    AddNote "Export Detail", "BDS Unit Price", "<", "-4999", "", "", "", "Site Manager Notes", _
      "Review - Low Dollar Value"
End Sub

Sub AddNote( _
    shName As String, _
    sTTCol As String, _
    operator1 As String, _
    testValue1 As String, _
    sWECol As String, _
    operator2 As String, _
    testValue2 As String, _
    sANCol As String, _
    note As String)

    '**************
    ' shName is the name of the sheet with the source table
    ' sTTCol is the name of the first column to search
    ' operator1 is the operation to perform on the sTTCol column: "=", "<>", "<", ">"
    ' testValue1 is the value to be compared with the cells found in the sTTCol column
    ' sWECol is the name of the second column to perform on once cell found in sTTCol,
    '   this is not needed and should be blank ("") so that no second comparing is done
    ' operator2 is the operator to perform in sWECol if used
    ' testValue2 is the value to be compared on sWECol if used
    ' sANCol is the name of the notes column
    ' note is the string to add to the notes column
    '*************
    
    Dim TTCol As Range
    Dim WECol As Range
    Dim ANCol As Range
    Dim rng As Range
    Dim cel As Range
    Dim cNote As Range
    Dim LR As Long

    With Sheets(shName)
        
        'TheSheet.Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)'
        Set TTCol = .Range("1:1").Find(sTTCol, , xlFormulas, xlWhole)
        If TTCol Is Nothing Then
            MsgBox sTTCol & " column not found"
            Exit Sub
        End If
        If sWECol <> "" Then
            Set WECol = .Range("1:1").Find(sWECol, , xlFormulas, xlWhole)
            If WECol Is Nothing Then
                MsgBox sTTCol & " column not found"
                Exit Sub
            End If
        End If
        Set ANCol = .Range("1:1").Find(sANCol, , xlFormulas, xlWhole)

        LR = .Cells(.Rows.Count, TTCol.Column).End(xlUp).Row
    
        Set rng = .Range(.Cells(2, TTCol.Column), .Cells(LR, TTCol.Column))
        For Each cel In rng
            If PerformOperator(cel, operator1, testValue1) Then
                Set cNote = .Cells(cel.Row, ANCol.Column)
                If Not WECol Is Nothing Then
                    If PerformOperator(.Cells(cel.Row, WECol.Column), operator2, testValue2) Then
                        If cNote.Value = "" Then
                            cNote.Value = note
                        Else
                            cNote.Value = .Cells(cel.Row, ANCol.Column).Value & "; " & note
                        End If
                    End If
                Else
                    If cNote.Value = "" Then
                        cNote.Value = note
                    Else
                        cNote.Value = .Cells(cel.Row, ANCol.Column).Value & "; " & note
                    End If
                End If
            End If
        Next cel
    End With
End Sub

Function PerformOperator(c As Range, operator As String, testValue As String) As Boolean
    PerformOperator = False
    Select Case operator
        Case "="
            If c.Value = testValue Then
                PerformOperator = True
            End If
        Case "<>"
            If c.Value <> testValue Then
                PerformOperator = True
            End If
        Case ">"
            If CLng(c.Value) > CLng(testValue) Then
                PerformOperator = True
            End If
        Case "<"
            If CLng(c.Value) < CLng(testValue) Then
                PerformOperator = True
            End If
    End Select
End Function

DanteAmor · Feb 3, 2022

I see the adding notes part was solved by shknbk2.
But I had already started working on the code and would like to contribute some improvements and simplifications to your code.

VBA Code:

Sub MyPricing()
  Dim f As Range
  Dim h As Variant
  Dim i As Long, j As Long
  Dim ANCol As Range, NCol As Range, PCol As Range, BDSCol As Range, CCol As Range, VCol As Range
  
  Application.ScreenUpdating = False

  'Insert Analyst Notes, Site Manager Notes and Corrections Column'
  Set f = Range("1:1").Find("BDS Unit Price", Cells(1, 1), xlValues, xlWhole, , , False)
  f.Offset(0, 1).Resize(1, 3).EntireColumn.Insert
  f.Offset(0, 1).Resize(1, 3).Value = Array("Analyst Notes", "Site Manager Notes", "Corrections")
  
  'Highlighting Columns'
  With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent2
    .TintAndShade = 0.599993896298105
    .PatternTintAndShade = 0
  End With

  'Format Date'
  For Each h In Array("EnteredDate", "WarrantyEnd", "RetiredDate", _
        "Proration Date", "Charged Date", "InstalledDate", "VendorContractEnd")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").NumberFormat = "m/d/yyyy"
  Next

  'Format Accounting'
  For Each h In Array("BDS Unit Price", "SVC", "Hospital Price", "FRP", "Net_CC_Price", _
    "Eq_Row", "True annual price", "Proration Amount", "Effective Price")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").Style = "Currency"
  Next

  'Format Width'
  Cells.ColumnWidth = 15

  'Reactivations'
  On Error Resume Next
  
  Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
  If ANCol Is Nothing Then MsgBox "Analyst Notes Column Not Found": Exit Sub
  
  Set NCol = Range("1:1").Find("Notes", , , xlWhole, , , False, , False)
  If NCol Is Nothing Then MsgBox "Notes Column Not Found": Exit Sub
  With NCol.EntireColumn
    .Replace "Standard Reactivations", "=true", xlWhole, , False, , False, False
    .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Reactivation"
    .Replace "=true", "Standard Reactivations", xlWhole, , False, , False, False
  End With
  
  'Proration'
  Set PCol = Range("1:1").Find("Proration Date", , , xlWhole, , , False, , False)
  If PCol Is Nothing Then MsgBox "Proration Date Column Not Found": Exit Sub
  With Range(PCol.Offset(1), Cells(Rows.Count, PCol.Column).End(xlUp))
    .SpecialCells(xlConstants).Offset(, ANCol.Column - PCol.Column).Value = "Review - Prorate?"
  End With
  
  'High Dollar Value'
  Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
  If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
  With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
    .Value = Evaluate(Replace(Replace("if(#>4999,""Review - High Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - ANCol.Column).Address))
  End With
  
'In this part, the SMNCol is not set, but it does not send you an error because you have the on error statement.
  'Low Dollar Value'
'  Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
'  If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
'  With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, SMNCol.Column - BDSCol.Column)
'    .Value = Evaluate(Replace(Replace("if(#<-4999,""Review - Low Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - SMNCol.Column).Address))
'  End With
  
  'Missing Coverage'
  Set CCol = Range("1:1").Find("Coverage", , , xlWhole, , , False, , False)
  If CCol Is Nothing Then MsgBox "Coverage Column Not Found": Exit Sub
  With CCol.EntireColumn
    .Replace "Missing Coverage", "=true", xlWhole, , False, , False, False
    .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Review - Missing Coverage"
    .Replace "=true", "Missing Coverage", xlWhole, , False, , False, False
  End With
  
  'Under Contract'
  Set VCol = Range("1:1").Find("VendorContract", , , xlWhole, , , False, , False)
  If VCol Is Nothing Then MsgBox "VendorContract Column Not Found": Exit Sub
  With Range(VCol.Offset(1), Cells(Rows.Count, VCol.Column).End(xlUp))
    .SpecialCells(xlConstants).Offset(, ANCol.Column - VCol.Column).Value = "Review - Contract"
  End With
  
  On Error GoTo 0
  
'Blank Warranty Addition'
  Dim TTCol As Range
  Dim WECol As Range
  Dim rng As Range
  Dim cel As Range
  Dim LR As Long
  Dim note As String
  note = "Review - Blank Warranty Addition"
  With Sheets("Export Detail")
    'TheSheet.Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)'
    Set TTCol = .Range("1:1").Find("Transaction Type", , xlValues, xlWhole)
    Set WECol = .Range("1:1").Find("WarrantyEnd", , xlValues, xlWhole)
    Set ANCol = .Range("1:1").Find("Analyst Notes", , xlValues, xlWhole)
    LR = .Cells(.Rows.Count, TTCol.Column).End(xlUp).Row
    Set rng = .Range(.Cells(2, TTCol.Column), .Cells(LR, TTCol.Column))
    For Each cel In rng
      If cel.Value = "Addition" Then
        If .Cells(cel.Row, WECol.Column) = "" Then
        'Insert Note After Existing Note'
        .Cells(cel.Row, ANCol.Column).Value = .Cells(cel.Row, ANCol.Column).Value & " " & note
        End If
      End If
    Next cel
  End With
'Blank Warranty Addition' end

  'Hiding Columns'
  For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    Select Case Cells(1, i).Value
      Case "SVC", "Modality", "EQStatus", "Sub Status", "InstalledDate", _
           "Ownership", "WarrantyCode", "VendorContract", "VendorContractEnd", _
           "ServiceStrategyYear1", "Pricing Method", "Notes", "Price_Type", _
           "Cust_Type", "Net_CC_Price", "Eq_Row", "True annual price", "Proration Amount"
        Columns(i).Hidden = True
    End Select
  Next
  
  'Highlighting Columns'
  With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent2
    .TintAndShade = 0.599993896298105
    .PatternTintAndShade = 0
  End With
  
  'Hide Exceptions'
  Worksheets("Exceptions").Visible = False
  'Select Cell A1'
  Range("Table1[[#Headers],[EquipmentID]]").Select
  Application.ScreenUpdating = True
End Sub

bmkelly · Feb 4, 2022

Thank you both! I received this code the other from an individual that currently works but I will take a look at both of yours and see how they work!

VBA Code:

Sub MyPricingTest()

Application.ScreenUpdating = False

    Dim f As Range
    Dim h As Variant
    Dim i As Long, j As Long
    Dim ANCol As Range, NCol As Range, PCol As Range, BDSCol As Range, CCol As Range, VCol As Range
    
'Change Header to Effective Price'
    Rows("1:1").Replace What:="*Impact*", Replacement:="Effective Price", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

'Insert Analyst Notes, Site Manager Notes and Corrections Column'
    Set f = Range("1:1").Find("BDS Unit Price", Cells(1, 1), xlValues, xlWhole, , , False)
        f.Offset(0, 1).Resize(1, 3).EntireColumn.Insert
        f.Offset(0, 1).Resize(1, 3).Value = Array("Analyst Notes", "Site Manager Notes", "Corrections")
  
  'Highlighting Columns'
    With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

  'Format Date'
    For Each h In Array("EnteredDate", "WarrantyEnd", "RetiredDate", _
        "Proration Date", "Charged Date", "InstalledDate", "VendorContractEnd")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").NumberFormat = "m/d/yyyy"
  Next

  'Format Accounting'
    For Each h In Array("BDS Unit Price", "SVC", "Hospital Price", "FRP", "Net_CC_Price", _
        "Eq_Row", "True annual price", "Proration Amount", "Effective Price")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").Style = "Currency"
  Next

  'Format Width'
  Cells.ColumnWidth = 15

  'Reactivations'
  On Error Resume Next
  
    Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
        If ANCol Is Nothing Then MsgBox "Analyst Notes Column Not Found": Exit Sub
  
    Set NCol = Range("1:1").Find("Notes", , , xlWhole, , , False, , False)
        If NCol Is Nothing Then MsgBox "Notes Column Not Found": Exit Sub
        With NCol.EntireColumn
            .Replace "Standard Reactivations", "=true", xlWhole, , False, , False, False
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Reactivation"
            .Replace "=true", "Standard Reactivations", xlWhole, , False, , False, False
        End With
  
  'Proration'
    Set PCol = Range("1:1").Find("Proration Date", , , xlWhole, , , False, , False)
        If PCol Is Nothing Then MsgBox "Proration Date Column Not Found": Exit Sub
        With Range(PCol.Offset(1), Cells(Rows.Count, PCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - PCol.Column).Value = "Review - Prorate?"
        End With
  
  'High Dollar Value'
    Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
        If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#>4999,""Review - High Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - ANCol.Column).Address))
        End With
  
  'Low Dollar Value'
    Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
        If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#<-4999,""Review - Low Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - SMNCol.Column).Address))
        End With
  
  'Missing Coverage'
    Set CCol = Range("1:1").Find("Coverage", , , xlWhole, , , False, , False)
        If CCol Is Nothing Then MsgBox "Coverage Column Not Found": Exit Sub
        With CCol.EntireColumn
            .Replace "Missing Coverage", "=true", xlWhole, , False, , False, False
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Review - Missing Coverage"
            .Replace "=true", "Missing Coverage", xlWhole, , False, , False, False
        End With
  
  'Under Contract'
    Set VCol = Range("1:1").Find("VendorContract", , , xlWhole, , , False, , False)
        If VCol Is Nothing Then MsgBox "VendorContract Column Not Found": Exit Sub
        With Range(VCol.Offset(1), Cells(Rows.Count, VCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - VCol.Column).Value = "Review - Contract"
        End With
  
  On Error GoTo 0
  
'Blank Warranty Addition'
    Dim TTCol As Range
    Dim WECol As Range
    Dim rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim note As String
        note = "Review - Blank Warranty Addition"
            With Sheets("Export Detail")
    'TheSheet.Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)'
    Set TTCol = .Range("1:1").Find("Transaction Type", , xlValues, xlWhole)
    Set WECol = .Range("1:1").Find("WarrantyEnd", , xlValues, xlWhole)
    Set ANCol = .Range("1:1").Find("Analyst Notes", , xlValues, xlWhole)
        LR = .Cells(.Rows.Count, TTCol.Column).End(xlUp).Row
    Set rng = .Range(.Cells(2, TTCol.Column), .Cells(LR, TTCol.Column))
        For Each cel In rng
            If cel.Value = "Addition" Then
            If .Cells(cel.Row, WECol.Column) = "" Then
        'Insert Note After Existing Note'
            .Cells(cel.Row, ANCol.Column).Value = .Cells(cel.Row, ANCol.Column).Value & " " & note
        End If
      End If
    Next cel
  End With
'Blank Warranty Addition' end

  'Hiding Columns'
    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        Select Case Cells(1, i).Value
            Case "SVC", "Modality", "EQStatus", "Sub Status", "InstalledDate", _
            "Ownership", "WarrantyCode", "VendorContract", "VendorContractEnd", _
            "ServiceStrategyYear1", "Pricing Method", "Notes", "Price_Type", _
            "Cust_Type", "Net_CC_Price", "Eq_Row", "True annual price", "Proration Amount"
        Columns(i).Hidden = True
    End Select
  Next
  
  'Highlighting Columns'
    With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
  End With
  
  'Hide Exceptions'
    Worksheets("Exceptions").Visible = False
  'Select Cell A1'
    Range("Table1[[#Headers],[EquipmentID]]").Select
    Application.ScreenUpdating = True
End Sub

bmkelly · Feb 4, 2022

bmkelly said:

Thank you both! I received this code the other from an individual that currently works but I will take a look at both of yours and see how they work!

VBA Code:

Sub MyPricingTest()

Application.ScreenUpdating = False

    Dim f As Range
    Dim h As Variant
    Dim i As Long, j As Long
    Dim ANCol As Range, NCol As Range, PCol As Range, BDSCol As Range, CCol As Range, VCol As Range
   
'Change Header to Effective Price'
    Rows("1:1").Replace What:="*Impact*", Replacement:="Effective Price", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

'Insert Analyst Notes, Site Manager Notes and Corrections Column'
    Set f = Range("1:1").Find("BDS Unit Price", Cells(1, 1), xlValues, xlWhole, , , False)
        f.Offset(0, 1).Resize(1, 3).EntireColumn.Insert
        f.Offset(0, 1).Resize(1, 3).Value = Array("Analyst Notes", "Site Manager Notes", "Corrections")
 
  'Highlighting Columns'
    With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

  'Format Date'
    For Each h In Array("EnteredDate", "WarrantyEnd", "RetiredDate", _
        "Proration Date", "Charged Date", "InstalledDate", "VendorContractEnd")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").NumberFormat = "m/d/yyyy"
  Next

  'Format Accounting'
    For Each h In Array("BDS Unit Price", "SVC", "Hospital Price", "FRP", "Net_CC_Price", _
        "Eq_Row", "True annual price", "Proration Amount", "Effective Price")
    Set f = Range("1:1").Find(h, , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then Range("Table1[[#All],[" & h & "]]").Style = "Currency"
  Next

  'Format Width'
  Cells.ColumnWidth = 15

  'Reactivations'
  On Error Resume Next
 
    Set ANCol = Range("1:1").Find("Analyst Notes", , , xlWhole, , , False, , False)
        If ANCol Is Nothing Then MsgBox "Analyst Notes Column Not Found": Exit Sub
 
    Set NCol = Range("1:1").Find("Notes", , , xlWhole, , , False, , False)
        If NCol Is Nothing Then MsgBox "Notes Column Not Found": Exit Sub
        With NCol.EntireColumn
            .Replace "Standard Reactivations", "=true", xlWhole, , False, , False, False
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Reactivation"
            .Replace "=true", "Standard Reactivations", xlWhole, , False, , False, False
        End With
 
  'Proration'
    Set PCol = Range("1:1").Find("Proration Date", , , xlWhole, , , False, , False)
        If PCol Is Nothing Then MsgBox "Proration Date Column Not Found": Exit Sub
        With Range(PCol.Offset(1), Cells(Rows.Count, PCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - PCol.Column).Value = "Review - Prorate?"
        End With
 
  'High Dollar Value'
    Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
        If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#>4999,""Review - High Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - ANCol.Column).Address))
        End With
 
  'Low Dollar Value'
    Set BDSCol = Range("1:1").Find("BDS Unit Price", , , xlWhole, , , False, , False)
        If BDSCol Is Nothing Then MsgBox "BDS Unit Price Column Not Found": Exit Sub
        With Range(BDSCol.Offset(1), Cells(Rows.Count, BDSCol.Column).End(xlUp)).Offset(, ANCol.Column - BDSCol.Column)
            .Value = Evaluate(Replace(Replace("if(#<-4999,""Review - Low Dollar Device"",if(@="""","""",@))", "@", .Address), "#", .Offset(, BDSCol.Column - SMNCol.Column).Address))
        End With
 
  'Missing Coverage'
    Set CCol = Range("1:1").Find("Coverage", , , xlWhole, , , False, , False)
        If CCol Is Nothing Then MsgBox "Coverage Column Not Found": Exit Sub
        With CCol.EntireColumn
            .Replace "Missing Coverage", "=true", xlWhole, , False, , False, False
            .SpecialCells(xlFormulas, xlLogical).Offset(, ANCol.Column - .Column).Value = "Review - Missing Coverage"
            .Replace "=true", "Missing Coverage", xlWhole, , False, , False, False
        End With
 
  'Under Contract'
    Set VCol = Range("1:1").Find("VendorContract", , , xlWhole, , , False, , False)
        If VCol Is Nothing Then MsgBox "VendorContract Column Not Found": Exit Sub
        With Range(VCol.Offset(1), Cells(Rows.Count, VCol.Column).End(xlUp))
            .SpecialCells(xlConstants).Offset(, ANCol.Column - VCol.Column).Value = "Review - Contract"
        End With
 
  On Error GoTo 0
 
'Blank Warranty Addition'
    Dim TTCol As Range
    Dim WECol As Range
    Dim rng As Range
    Dim cel As Range
    Dim LR As Long
    Dim note As String
        note = "Review - Blank Warranty Addition"
            With Sheets("Export Detail")
    'TheSheet.Range.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)'
    Set TTCol = .Range("1:1").Find("Transaction Type", , xlValues, xlWhole)
    Set WECol = .Range("1:1").Find("WarrantyEnd", , xlValues, xlWhole)
    Set ANCol = .Range("1:1").Find("Analyst Notes", , xlValues, xlWhole)
        LR = .Cells(.Rows.Count, TTCol.Column).End(xlUp).Row
    Set rng = .Range(.Cells(2, TTCol.Column), .Cells(LR, TTCol.Column))
        For Each cel In rng
            If cel.Value = "Addition" Then
            If .Cells(cel.Row, WECol.Column) = "" Then
        'Insert Note After Existing Note'
            .Cells(cel.Row, ANCol.Column).Value = .Cells(cel.Row, ANCol.Column).Value & " " & note
        End If
      End If
    Next cel
  End With
'Blank Warranty Addition' end

  'Hiding Columns'
    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        Select Case Cells(1, i).Value
            Case "SVC", "Modality", "EQStatus", "Sub Status", "InstalledDate", _
            "Ownership", "WarrantyCode", "VendorContract", "VendorContractEnd", _
            "ServiceStrategyYear1", "Pricing Method", "Notes", "Price_Type", _
            "Cust_Type", "Net_CC_Price", "Eq_Row", "True annual price", "Proration Amount"
        Columns(i).Hidden = True
    End Select
  Next
 
  'Highlighting Columns'
    With Range("Table1[[#All],[Analyst Notes]:[Corrections]]").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
  End With
 
  'Hide Exceptions'
    Worksheets("Exceptions").Visible = False
  'Select Cell A1'
    Range("Table1[[#Headers],[EquipmentID]]").Select
    Application.ScreenUpdating = True
End Sub

sorry correction -

VBA Code:

Sub The_Whole_Thing()
    
    Dim oLo As ListObject, i As Long, note As String
    
Set oLo = Sheets("Export Detail").ListObjects("Table1")

Application.ScreenUpdating = False

With oLo
    For i = 1 To .ListRows.Count
    
        'Blank Warranty Addition'
        ' the note to add
        note = "Review - Blank Warranty Addition"
        'If you call by the name of the column, then the column index will be 1 for that range
        If .ListColumns("Transaction Type").DataBodyRange(i, 1).Value = "Addition" Then
            ' if site manager notes IS BLANK put in the note
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                ' if site manager notes is NOT BLANK then check if this note already exists
                ' if it's not add it to whats already there
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                   .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
         
        'Reactivations'
        note = "Reactivation"
        If .ListColumns("Notes").DataBodyRange(i, 1).Value = "Standard Reactivations" Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If

        'Proration'
        note = "Review - Prorate?"
        If IsDate(.ListColumns("Proration Date").DataBodyRange(i, 1).Value) Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                 .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
        
        'High Dollar Value'
        note = "Review - High Dollar Value"
        If .ListColumns("BDS Unit Price").DataBodyRange(i, 1).Value > 4999 Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                 .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
        
        'Low Dollar Value'
        note = "Review - Low Dollar Value"
        If .ListColumns("BDS Unit Price").DataBodyRange(i, 1).Value < 4999 Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                 .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
        
        'Missing Coverage'
        note = "Review - Missing Coverage"
        If .ListColumns("Coverage").DataBodyRange(i, 1).Value = "Missing Coverage" Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                 .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
        
        'Under Contract'
        note = "Review - Contract"
        If .ListColumns("VendorContract").DataBodyRange(i, 1).Value <> "" Then
            If Len(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value) = 0 Then
                 .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = note
            Else
                If InStr(.ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value, note) = 0 Then
                    .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value = _
                     .ListColumns("Site Manager Notes").DataBodyRange(i, 1).Value & Chr(10) & note
                End If
            End If
        End If
    
    Next i
    
End With

Application.ScreenUpdating = True

End Sub

macro to add text to existing text and not overwrite

bmkelly

Board Regular

Excel Facts

shknbk2

Well-known Member

DanteAmor

Well-known Member

bmkelly

Board Regular

bmkelly

Board Regular

Similar threads

Forum statistics

Share this page

macro to add text to existing text and not overwrite

bmkelly

Board Regular

Excel Facts

shknbk2

Well-known Member

DanteAmor

Well-known Member

bmkelly

Board Regular

bmkelly

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock