Excel VBA: Combine Rows Based on Duplicate Value In Column and Combine Cell Value

Try the RemoveDuplicates macro in this workbook. It works against a sheet I named "Test". The other one's there for backup.
Q-28686598.xlsm

Hi Martin, thanks for the prompt assistance. The Host in column L are not aggregating. For example, every host that has a plugin should be in the merged row column L. When the row gets deleted, it should update the L cell.

sorry meant "every host that has a plugin duplicate". So 10907 should have many host in column L.

Ok. I'm out for the rest of the day and I'll look into it tomorrow.

Maybe I'm misunderstanding your request, but do you wish all the DNS Name values for duplicate Plugin values to be combined into a single cell?  If so, how do you want them delimited (space, comma, semi-colon, other?)

For example, for Plugin value 10907, only the content in Row 2 would be kept and the value in cell L2 would be:

ANTHOST050z.NZDOMAIN.LOCAL, ANTHOST050z.NZDOMAIN.LOCAL, ANTHOST855z.NZDOMAIN.LOCAL, ANTHOST203z.NZDOMAIN.LOCAL, ANTHOST025p.NZDOMAIN.LOCAL, ANTHOST029p.NZDOMAIN.LOCAL, ANTHOST031P.NZDOMAIN.LOCAL, ANTHOST032P.NZDOMAIN.LOCAL, ANTHOST034p.NZDOMAIN.LOCAL, ANTHOST035p.NZDOMAIN.LOCAL, ANTHOST037p.NZDOMAIN.LOCAL, ANTHOST041p.NZDOMAIN.LOCAL, ANTHOST042p.NZDOMAIN.LOCAL, ANTHOST045p.NZDOMAIN.LOCAL, ANTHOST048p.NZDOMAIN.LOCAL, ANTHOST050p.NZDOMAIN.LOCAL, ANTHOST065p.NZDOMAIN.LOCAL, ANTHEST020p.NZDOMAIN.LOCAL, ANTHEST024p.NZDOMAIN.LOCAL, ANTHEST027p.NZDOMAIN.LOCAL, ANTHEST036p.NZDOMAIN.LOCAL, ANTHEST037p.NZDOMAIN.LOCAL, ANTHEST038p.NZDOMAIN.LOCAL, ANTHEST041p.NZDOMAIN.LOCAL, ANTHEST042p.NZDOMAIN.LOCAL, ANTHEST043p.NZDOMAIN.LOCAL, ANTHEST045p.NZDOMAIN.LOCAL, ANTHEST050p.NZDOMAIN.LOCAL, ANTHEST051p.NZDOMAIN.LOCAL, ANTHOST66666z.NZDOMAIN.LOCAL, ANTHOST55555z.NZDOMAIN.LOCAL, ANTHOST018P.NZDOMAIN.LOCAL, ANTHOST019P.NZDOMAIN.LOCAL, ANTHOST021P.NZDOMAIN.LOCAL, ANTHOST022P.NZDOMAIN.LOCAL, ANTHOST023P.NZDOMAIN.LOCAL, ANTHOST024P.NZDOMAIN.LOCAL, ANTHOST027P.NZDOMAIN.LOCAL, ANTHOST030P.NZDOMAIN.LOCAL, ANTHOST031P.NZDOMAIN.LOCAL, ANTHOST032P.NZDOMAIN.LOCAL

Regards,
-Glenn

Exactly, the plugin is on different host. So I was hoping to have all the host with that plugin enumerated in the cell on that row please

Here's an update. In this version the DNS Names are in a simple list. If you want them like Glenn shows them (3 per line, comma-separated) then I can do that.
Q-28686598a.xlsm

martin,
Thanks for your support; however, we are not meeting the objective. See attached screenshot. Each plugin (another Nessus name for a vulnerability ID) should have all its host in column L.  There should be no empty cells in L because if the plugin/vulnerability is there, It must have been found on at least one host. So if there is a plugin/vulnerability listed, there is a host that has it.
I was hoping to have this in user created VBA code instead of macro code. I  can read and update traditional user code (loops, arrays, and variables); however, office generated macro code is new to me and more difficult to update/append.

I tried to do this myself with an outer and inner loop that compares plugins and if there is a match, store the host in a dynamic array an then update column L. the problem was when I deleted rows in my inner loop, things got hosed. So I am looking for a different approach by another programmer. Thank you sir.
missing-host.png

Each plugin (another Nessus name for a vulnerability ID) should have all its host in column L.

If you run my macro 41 hosts wind up in range(L2) which is what Glen showed in his example. Mine are a simple list while his are 3 in a line.

There should be no empty cells in L

I don't think there were any. If you expand the hight quite a bit of the rows with  "blank" cell in col L, I think you'll see there's something there. It's not correct but it's there. I didn't know this before but apparently there's a maximum row height and I was listing the hosts in a 1-wide list and when the height of the list exceeded the maximum row height most (if not all) of the data was lost. I've made the list 3-wide and that problem is gone.

I was hoping to have this in user created VBA code instead of macro code. I  can read and update traditional user code (loops, arrays, and variables); however, office generated macro code is new to me and more difficult to update/append.

I don't understand what you mean by " office generated macro code". I wrote the code that is in the workbook and this time I documented it. If you need more explanation please let me know.

The workbook that I'm attaching shows the results of the RemoveDuplicates macro having been run, and I expanded some rows and widened col L so you can see some of the results. If you want to run the RemoveDuplicates macro again, first run the macro that you'll find in Module2 which will delete the Test sheet and create a new one.

BTW, code could be added to automatically expand the height of the rows and the width of column L so that all the data shows.
Q-28686598b.xlsm

I think my 'b' version above is what you asked for, but this version shows the results of running a different macro called RemoveDuplicates2.
Q-28686598c.xlsm

We are almost there!  Very close.

Instead of the blanks cells, for each plugin, all the host should be in that L column. I have attached a screenshot.
WIll this work as I get new sheets like this in the future, I just run that macro and it will do this?
plugin-hosts-in-L.png

Thank you Martin. I have decided to implement version b into my project.
Again, I appreciate your solution. More importantly, I appreciate your patience with me.

Martin is very patient and wants to completely understand the problem. He works diligently and provided me with daily updates for his solution.

I'd be happy to do more with the workbook if you wanted it. For example it would be easy to show the data at the top of the row rather than at the bottom. In other words it would look like this.
 Another change that could be made would to automatically expand the height of the rows and the width of column L so that all the data shows. This could be done in the RemoveDuplicates macro so that all the rows are expanded all at once, or it could be done when you click on a cell in column "L". BTW what do you do with the data in that column? Do you just look at it? If you use it in some other way like copying it then I might be able to do something else.

In any case you're welcome and I'm glad I was able to help.

In my profile you'll find links to some articles I've written that may interest you.
Marty - MVP 2009 to 2015

Hi Martin,
I am having one more small issue with bringing in your code. If you could take a look, I would appreciate it.

I have attached the completed workbook (the proof of concept anyway).
1. The user clicks a button and then browses for a csv file.
2. The CSV file is then converted to an XLS file and the remote sheet is copied to my local spreadsheet as a new worksheet.
3. At that point the worksheet is processed.
4. The user then knows which vulnerabilities need to be fixed.

I have imported your code and getting an error with regard to the threeinline function. Maybe you could run the attached and see if you could have a look at it? For the CSV file, browse for the one I included in my first comment above here: http://filedb.experts-exchange.com/incoming/2015/06_w23/917388/example.csv

Just open the Import ACAS file and click the button and browse for the CSV.

Thanks in advance.
Import-ACAS.xls

I can reproduce the problem and I'm looking into the cause now.

OK, fixed. Substitute the code below. The problem was that in a couple of places I had statements like line 149 where I had strOldPlugin = Cells(lngLastRow, 1) rather than strOldPlugin = .Cells(lngLastRow, 1) (note the period before "Cells"). With the period it refers to sheet newxlsWSName because it's within the 'With' block for the sheet and without it at may not and at some point ThreeInLine was being sent a blank strHost.

Here's an unrelated suggestion. Change line 186 to Columns("L").AutoFit

I also have a question. At line 105 you Set ASheet = ActiveSheet but at lines 118 and 120 you Select it and set it to Nothing without seeming to have done anything with the sheet. Why?

Sub Convert_ACAS_CSV_To_Excel_File()
    
    Dim csvFilePath As Variant
    Dim csvFileName
    Dim csvDirectoryName
    Dim newxlsName
    Dim newxlsWSName
    Dim newxlsFilePath
    Dim FSO
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim SourceWB As Workbook
    Dim ASheet As Worksheet
    Dim sheet
    Dim i, j, lastRow
    Dim columnA, columnB, columnC, columnL, columnM
    Dim compareA, compareB, compareC, compareL, compareM
    Dim myCount
    Dim mytimeSavings, myprocessMessage, myhoursSaved, myminutes
    Dim strCleanFileName
    Dim lngLastRow As Long
    Dim lngLastCol As Long
    Dim lngRow As Long
    Dim lngEndRow As Long
    Dim strOldPlugin As String
    Dim strHost As String
    Dim strLastCol As String
   
   
    MsgBox "Browse for the ACAS 'Detailed Vuln' Report, it will be a .csv file"
    
    'Open a dialog and browse to the ACAS csv file and put the file path in a variable
    csvFilePath = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv),*.csv", Title:="Select a CSV File", MultiSelect:=False)
    If csvFilePath = False Then Exit Sub

    
    'Only get the directory name from the path
    csvDirectoryName = FolderFromPath(csvFilePath)
    
    strCleanFileName = csvDirectoryName & Format(Now(), "yyMMdd_hhmmAM/PM") & ".csv"
    
    Name csvFilePath As strCleanFileName
    
    csvFilePath = strCleanFileName
    
    'Only get the file name from the path
    csvFileName = GetFilenameFromPath(csvFilePath)
    MsgBox csvFilePath
    
    'Get the worksheet name in the new xls file
    newxlsWSName = csvFileName
    newxlsWSName = Trim(newxlsWSName)
    newxlsWSName = Replace(newxlsWSName, ".csv", "")
    newxlsWSName = Replace(newxlsWSName, ".xls", "")
    newxlsWSName = Replace(newxlsWSName, ".", "")
    newxlsWSName = Replace(newxlsWSName, ")", "")
    newxlsWSName = Replace(newxlsWSName, "(", "")
    newxlsWSName = Replace(newxlsWSName, "", "")
    newxlsWSName = Replace(newxlsWSName, " ", "")

    'Only get the directory name from the path
    csvDirectoryName = FolderFromPath(csvFilePath)
    
    'Create a file name for the newly created xls file
    newxlsName = csvFileName
    newxlsName = Replace(newxlsName, "", "_")
    newxlsName = Replace(newxlsName, " ", "_")
    newxlsName = Replace(newxlsName, ")", "")
    newxlsName = Replace(newxlsName, "(", "")
    newxlsName = Replace(newxlsName, ".csv", ".xls")
    newxlsName = "ACAStoRAR_" & newxlsName
    
    newxlsFilePath = csvDirectoryName & newxlsName
    
    'Set Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Check File Exists or Not, if so delete it.
    If FSO.FileExists(newxlsFilePath) Then
        FSO.DeleteFile newxlsFilePath, True
    End If
    
    'If a worksheet with this name already exists, delete it.
    For Each ws In Worksheets
    If ws.Name = newxlsWSName Then
        Application.DisplayAlerts = False
        Sheets(newxlsWSName).Delete
        Application.DisplayAlerts = True
    End If
    Next
  
    Workbooks.Open Filename:=csvFilePath
    Application.DisplayAlerts = False 'prevents asking questions
    ActiveWorkbook.SaveAs Filename:=newxlsFilePath, _
    FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    Workbooks(newxlsName).Close
            
    'Turns off screenupdating and events:
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'Sets the variables:
    Set wb = ActiveWorkbook
    Set ASheet = ActiveSheet
    Set SourceWB = Workbooks.Open(newxlsFilePath)  'Modify to match
    
    'Copies each sheet of the SourceWB to the end of original wb:
    For Each ws In SourceWB.Worksheets
        ws.Copy after:=wb.Sheets(wb.Sheets.Count)
    Next ws
    
    SourceWB.Close savechanges:=False
    Set ws = Nothing
    Set SourceWB = Nothing
    
    wb.Activate
    ASheet.Select

    Set ASheet = Nothing
    Set wb = Nothing
    
    Application.EnableEvents = True
    Set sheet = ActiveWorkbook.Sheets(newxlsWSName)

    Application.ScreenUpdating = False
    'Application.Cursor = xlWait
    Sheets(newxlsWSName).Select
    With Sheets(newxlsWSName)
        ' Find the last row and co,umn on the sheet
        lngLastRow = .Range("A65536").End(xlUp).Row
        lngLastCol = .Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
        ' Convert the last column number to a string
        strLastCol = Split(Cells(1, lngLastCol).Address, "$")(1)
        ' Sort the sheet on col "A"
        .Columns("A:A").Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A1") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With Sheets(newxlsWSName).Sort
            .SetRange Range("A2:" & ColNumToLetter(lngLastCol) & lngLastRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    ' Read the rows backward until we detect a new plugin
    strOldPlugin = .Cells(lngLastRow, 1)
    lngEndRow = lngLastRow
    For lngRow = lngLastRow To 2 Step -1
        If lngRow = 2 Then
            ' EOJ processing
            .Range("A" & lngRow + 1 & ":" & strLastCol & lngEndRow).Delete
            .Cells(2, "L") = ThreeInLine(strHost)
        Else
            If .Cells(lngRow - 1, 1) <> strOldPlugin Then
                ' A new pluging has been found so delete all but the first
                ' row of the old plugin
                .Range("A" & lngRow + 1 & ":" & strLastCol & lngEndRow).Delete
'                ' Convert the plugin string to a 3-wide list
                .Cells(lngRow, "L") = ThreeInLine(strHost)
                strHost = .Cells(lngRow - 1, "L") & "|"
                strOldPlugin = .Cells(lngRow - 1, 1)
                lngEndRow = lngRow - 1
            Else
                ' Create a string of pipe separated values
                strHost = strHost & .Cells(lngRow, "L") & "|"
            End If
        End If
        
    Application.ScreenUpdating = True
    'Application.Cursor = xlDefault
    Next
        .Columns("A").ColumnWidth = 5
        .Columns("B").ColumnWidth = 20
        .Columns("B").WrapText = True
        .Columns("D").ColumnWidth = 6.5
        .Columns("E").ColumnWidth = 3
        .Columns("F").ColumnWidth = 4
        .Columns("G").ColumnWidth = 4
        .Columns("H").ColumnWidth = 4
        .Columns("I").ColumnWidth = 4
        .Columns("J").ColumnWidth = 4
        .Columns("K").ColumnWidth = 4
        .Columns("L").ColumnWidth = 24
        .Columns("M").ColumnWidth = 30
        .Columns("N").ColumnWidth = 30
        .Columns("N").WrapText = True
        .Columns("O").ColumnWidth = 25
        .Columns("O").WrapText = True
        .Columns("P").ColumnWidth = 30
        .Columns("P").WrapText = True
        .Columns("Q").ColumnWidth = 25
        .Columns("Q").WrapText = True
    End With
     
    mytimeSavings = myCount - lastRow
    myminutes = mytimeSavings * 0.5
    myhoursSaved = myminutes / 60
    myprocessMessage = "ACAS report duplicate reduction from: " & myCount & " rows to " & lastRow
    myprocessMessage = myprocessMessage & vbCr & "At approximately 30 seconds of manual analysis per row. "
    myprocessMessage = myprocessMessage & vbCr & "This is a total savinge of: " & myminutes & " minutes."
    myprocessMessage = myprocessMessage & vbCr & "This equates to approximately: " & Round(myhoursSaved, 1) & " hours"
    
    MsgBox myprocessMessage

End Sub

Select allOpen in new window

I have made the updates you have suggested in the attached file. Now two things are happening.
1. It doesn't like this line after I made the updates:

ThreeInLine = Left$(ThreeInLine, Len(ThreeInLine) - 2)]

Select allOpen in new window

2. When I comment this out, it loops for a very long time and then prints nothing to our rows. The only thing printed is the heading only.
Import-ACAS.xls

In case you (or I) missed something here is the workbook you posted in post ID: 40818717 after I ran it against the csv file you posted in the same post.
Import-ACAS.xls

Sorry here is the one having the issues I mentioned in post 40819237 after I made your corrections.
Import-ACAS.xls

I'm sorry but the workbook you just uploaded does not have the changes. In any case here's how to do them. Click your mouse on any row in the Convert_ACAS_CSV_To_Excel_File sub. Click Ctrl+F and do a search as shown below.

Keep clicking 'Find Next' until you find a Cell with no period in front of it. When you find one, add the missing period. There's a total of 4 of them.

The difference in the file name is _ or - and that is what cause me to upload wrong one. Sorry to waste your time.
I have attached the file, the changes I made screenshot, and the error screenshot.
Import-ACAS.xls
recommended-changes.png
errors.png

The changes from Cell to .Cell still were not made in that workbook either. Replace the sub with this one by copying and pasting this code. And out of curiosity why did you comment out the two lines that turn the hourglass cursor on (xlWait) and off (xlDefault)?

Sub Convert_ACAS_CSV_To_Excel_File()
    
    Dim csvFilePath As Variant
    Dim csvFileName
    Dim csvDirectoryName
    Dim newxlsName
    Dim newxlsWSName
    Dim newxlsFilePath
    Dim FSO
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim SourceWB As Workbook
    Dim ASheet As Worksheet
    Dim sheet
    Dim i, j, lastRow
    Dim columnA, columnB, columnC, columnL, columnM
    Dim compareA, compareB, compareC, compareL, compareM
    Dim myCount
    Dim mytimeSavings, myprocessMessage, myhoursSaved, myminutes
    Dim strCleanFileName
    Dim lngLastRow As Long
    Dim lngLastCol As Long
    Dim lngRow As Long
    Dim lngEndRow As Long
    Dim strOldPlugin As String
    Dim strHost As String
    Dim strLastCol As String
   
   
    MsgBox "Browse for the ACAS 'Detailed Vuln' Report, it will be a .csv file"
    
    'Open a dialog and browse to the ACAS csv file and put the file path in a variable
    csvFilePath = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv),*.csv", Title:="Select a CSV File", MultiSelect:=False)
    If csvFilePath = False Then Exit Sub

    
    'Only get the directory name from the path
    csvDirectoryName = FolderFromPath(csvFilePath)
    
    strCleanFileName = csvDirectoryName & Format(Now(), "yyMMdd_hhmmAM/PM") & ".csv"
    
    Name csvFilePath As strCleanFileName
    
    csvFilePath = strCleanFileName
    
    'Only get the file name from the path
    csvFileName = GetFilenameFromPath(csvFilePath)
    MsgBox csvFilePath
    
    'Get the worksheet name in the new xls file
    newxlsWSName = csvFileName
    newxlsWSName = Trim(newxlsWSName)
    newxlsWSName = Replace(newxlsWSName, ".csv", "")
    newxlsWSName = Replace(newxlsWSName, ".xls", "")
    newxlsWSName = Replace(newxlsWSName, ".", "")
    newxlsWSName = Replace(newxlsWSName, ")", "")
    newxlsWSName = Replace(newxlsWSName, "(", "")
    newxlsWSName = Replace(newxlsWSName, "", "")
    newxlsWSName = Replace(newxlsWSName, " ", "")

    'Only get the directory name from the path
    csvDirectoryName = FolderFromPath(csvFilePath)
    
    'Create a file name for the newly created xls file
    newxlsName = csvFileName
    newxlsName = Replace(newxlsName, "", "_")
    newxlsName = Replace(newxlsName, " ", "_")
    newxlsName = Replace(newxlsName, ")", "")
    newxlsName = Replace(newxlsName, "(", "")
    newxlsName = Replace(newxlsName, ".csv", ".xls")
    newxlsName = "ACAStoRAR_" & newxlsName
    
    newxlsFilePath = csvDirectoryName & newxlsName
    
    'Set Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Check File Exists or Not, if so delete it.
    If FSO.FileExists(newxlsFilePath) Then
        FSO.DeleteFile newxlsFilePath, True
    End If
    
    'If a worksheet with this name already exists, delete it.
    For Each ws In Worksheets
    If ws.Name = newxlsWSName Then
        Application.DisplayAlerts = False
        Sheets(newxlsWSName).Delete
        Application.DisplayAlerts = True
    End If
    Next
  
    Workbooks.Open Filename:=csvFilePath
    Application.DisplayAlerts = False 'prevents asking questions
    ActiveWorkbook.SaveAs Filename:=newxlsFilePath, _
    FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
    ReadOnlyRecommended:=False, CreateBackup:=False
    Workbooks(newxlsName).Close
            
    'Turns off screenupdating and events:
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'Sets the variables:
    Set wb = ActiveWorkbook
    Set ASheet = ActiveSheet
    Set SourceWB = Workbooks.Open(newxlsFilePath)  'Modify to match
    
    'Copies each sheet of the SourceWB to the end of original wb:
    For Each ws In SourceWB.Worksheets
        ws.Copy after:=wb.Sheets(wb.Sheets.Count)
    Next ws
    
    SourceWB.Close savechanges:=False
    Set ws = Nothing
    Set SourceWB = Nothing
    
    wb.Activate
    ASheet.Select

    Set ASheet = Nothing
    Set wb = Nothing
    
    Application.EnableEvents = True
    Set sheet = ActiveWorkbook.Sheets(newxlsWSName)

    Application.ScreenUpdating = False
    'Application.Cursor = xlWait
    Sheets(newxlsWSName).Select
    With Sheets(newxlsWSName)
        ' Find the last row and co,umn on the sheet
        lngLastRow = .Range("A65536").End(xlUp).Row
        lngLastCol = .Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
        ' Convert the last column number to a string
        strLastCol = Split(.Cells(1, lngLastCol).Address, "$")(1)
        ' Sort the sheet on col "A"
        .Columns("A:A").Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("A1") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With Sheets(newxlsWSName).Sort
            .SetRange Range("A2:" & ColNumToLetter(lngLastCol) & lngLastRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    ' Read the rows backward until we detect a new plugin
    strOldPlugin = .Cells(lngLastRow, 1)
    lngEndRow = lngLastRow
    For lngRow = lngLastRow To 2 Step -1
        If lngRow = 2 Then
            ' EOJ processing
            .Range("A" & lngRow + 1 & ":" & strLastCol & lngEndRow).Delete
            .Cells(2, "L") = ThreeInLine(strHost)
        Else
            If .Cells(lngRow - 1, 1) <> strOldPlugin Then
                ' A new pluging has been found so delete all but the first
                ' row of the old plugin
                .Range("A" & lngRow + 1 & ":" & strLastCol & lngEndRow).Delete
'                ' Convert the plugin string to a 3-wide list
                .Cells(lngRow, "L") = ThreeInLine(strHost)
                strHost = .Cells(lngRow - 1, "L") & "|"
                strOldPlugin = .Cells(lngRow - 1, 1)
                lngEndRow = lngRow - 1
            Else
                ' Create a string of pipe separated values
                strHost = strHost & .Cells(lngRow, "L") & "|"
            End If
        End If
        
    Application.ScreenUpdating = True
    'Application.Cursor = xlDefault
    Next
        .Columns("A").ColumnWidth = 5
        .Columns("B").ColumnWidth = 20
        .Columns("B").WrapText = True
        .Columns("D").ColumnWidth = 6.5
        .Columns("E").ColumnWidth = 3
        .Columns("F").ColumnWidth = 4
        .Columns("G").ColumnWidth = 4
        .Columns("H").ColumnWidth = 4
        .Columns("I").ColumnWidth = 4
        .Columns("J").ColumnWidth = 4
        .Columns("K").ColumnWidth = 4
        .Columns("L").AutoFit
        .Columns("M").ColumnWidth = 30
        .Columns("N").ColumnWidth = 30
        .Columns("N").WrapText = True
        .Columns("O").ColumnWidth = 25
        .Columns("O").WrapText = True
        .Columns("P").ColumnWidth = 30
        .Columns("P").WrapText = True
        .Columns("Q").ColumnWidth = 25
        .Columns("Q").WrapText = True
    End With
     
    mytimeSavings = myCount - lastRow
    myminutes = mytimeSavings * 0.5
    myhoursSaved = myminutes / 60
    myprocessMessage = "ACAS report duplicate reduction from: " & myCount & " rows to " & lastRow
    myprocessMessage = myprocessMessage & vbCr & "At approximately 30 seconds of manual analysis per row. "
    myprocessMessage = myprocessMessage & vbCr & "This is a total savinge of: " & myminutes & " minutes."
    myprocessMessage = myprocessMessage & vbCr & "This equates to approximately: " & Round(myhoursSaved, 1) & " hours"
    
    MsgBox myprocessMessage

End Sub

Select allOpen in new window