Merge cells and delete duplicate data - vba

Question

I have a list of companies and each has a scope of work, address and phone number. Some of the companies have multiple scopes of work. It looks something like this:
I want to get rid of the second copy of the stuff like the address (and in my case phone numbers and such) while copying the unique data in the second line and putting it in the first line and then getting rid of the second line.
I have very little experience of coding. I looked up how to do this step by step but something is wrong within the code or the syntax:
I found code for going down a column for a blank space.
I looked up how I would copy a cell to the right of the active blank cell.
I found code for merging the info into the cell one above and one to the right of the active cell.
I found code that deletes the row with the active cell.
I want it to loop until there are no more blank company cells.
So this is how I put it together:
Public Sub SelectFirstBlankCell()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
Do
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
End If
Next
Loop Until A647
End Sub
.
Sub mergeIt()
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(1, 1)).Merge
ActiveCell.Select
End Sub
.
Sub DeleteRow()
RowNo = ActiveCell.Row
If RowNo < 7 Then Exit Sub
Range("A" & ActiveCell.Row).EntireRow.Delete
Sheets("Summary").Select
Range("A4:O4").Select
Selection.Copy
LastRow = Range("A65536").End(xlUp).Offset(1, 0).Row
End Sub

Answer 1

Please never post code as an image since someone who wants to try it out must type it. You can edit your question and add a new section including revised code if necessary.
My copy of your code (plus line numbers) is:
1 Public Sub SelectFirstBlankCell()
2 Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
3 Dim currentRowValue As String
4 sourceCol = 1 'column F has a value of 6
5 rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
6 'for every row, find the first blank cell and select it
7 For currentRow = 1 To rowCount
8 currentRowValue = Cells(currentRow, sourceCol).Value
9 If IsEmpty(currentRowValue) Or currentRowValue = "" Then
10 Cells(currentRow, sourceCol).Select
11 End If
12 Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 1)).Merge
13 ActiveCell.Select
14 If IsEmpty(currentRowValue) Or currentRowValue = "" Then
15 Cells(Range("sourceCol:21")).Delete
16 End If
17 Next
18 End Sub
I am sure we all started selecting cells and accessing the ActiveCell because the macro recorder does this. However, selecting cells is slow and it is very easy to lose track of what is selected. I believe this is your main problem.
Problem 1 The end value for a For-Loop is fixed at the start; Any attempt to reduce rowCount when you delete something will have no effect on the For-Loop.
Problem 2 I suspect you mean the range in line 15 to be sourceCol & ":" & currentRow.
Problem 3 In line 10 you select a cell if it is blank. In line 12 you merge the active cell whether or not you have just selected it. This means your code attempts a merge for every row.
Problem 4 Column 1 is the column that might be blank. Suppose row 1000 is the last row with a supplier's name but row 1005 is the last row with a product. Your code would not process rows 1001 to 1005.
Problem 5 Function IsEmpty() only returns sensible values for Variants. A Variant is either a cell or a variable that can hold different types of value.
I have not tried your code so there may be more mistakes. Do get dispirited. To the best of my knowledge, problem 1 is not documented. I had to discover this "feature" for myself by attempting code similar to yours. The specification for Function IsEmpty() states its limitations but, unless you fully understand Variants, the significance is not obvious. The other problems are easy errors to make and only practice will reduce their frequency.
Below is my solution to your problem. It is not how I would code it for myself but I think I have introduced enough new concepts for one solution.
I do not say much about the syntax of the VBA statements I use since it is usually easy to look up a statement once you know it exists. Ask if necessary but please try to understand the code before asking.
I do not like deleting in situ; it is slow and, if your code is faulty, you have to load the previous version of the worksheet and start again. I have a source (Src) and a Destination (Dest) worksheet.
I use constants for values that might change but not during a single run of your macro.
You assume the address and other details for Jan's Supply on rows 2 and 3 match. I am paranoid and never make assumptions like this. If my code would discard important information if rows 2 and 3 did not match, I check they match. I also allow for rows like this because I have encountered them:
John's supply Cookies 555 Main Street CA
Cakes Littleville CA
This will become:
John's supply Cookies & Cakes 555 Main Street Littleville CA
Some of the comments explain my choice of VBA statement but most do not. When you have to update a macro you wrote 12 months ago for new requirements, the few minutes you spent adding comments can save you hours finding your way around the code.
You may not like my system of naming variables. Fine; develop your own. When you return to this macro in 12 months, an immediate understanding of the variables will save more time.
Option Explicit
Const WkshtSrcName As String = "Sheet1" ' \ Replace "Sheet1" and "Sheet2"
Const WkshtDestName As String = "Sheet2" ' / with the names of your worksheets
Const ColSupplier As String = "A" ' \ In Cells(R, C), C can be a
Const ColProduct As String = "B" ' / number or a column identifier
Const RowDataFirst As Long = 1
Sub MergeRowsForSameSupplier()
Dim ColCrnt As Long ' \ Columns in source and destination are the
Dim ColMax As Long ' / same so single variables are adequate.
Dim RowDestCrnt As Long ' \ Rows in source and destination
Dim RowSrcCrnt As Long ' | worksheets are different
Dim RowSrcMax As Long ' / so need separate variables.
Dim ProductCrnt As String
Dim Join As String
Dim SupplierCrnt As String
Dim WkshtSrc As Worksheet
Dim WkshtDest As Worksheet
Set WkshtSrc = Worksheets(WkshtSrcName)
Set WkshtDest = Worksheets(WkshtDestName)
With WkshtSrc
' I consider this to be the easiest technique of identifying the last used
' row and column in a worksheet. Note: the used range includes trailing
' rows and columns that are formatted but otherwise unused or were used but
' aren't now so other techniques can better match what the user or the
' programmer usually mean by "used".
ColMax = .UsedRange.Columns.Count
RowSrcMax = .UsedRange.Rows.Count
End With
With WkshtDest
.Cells.EntireRow.Delete ' Delete any existing contents
End With
RowDestCrnt = RowDataFirst
For RowSrcCrnt = RowDataFirst To RowSrcMax
With WkshtSrc
SupplierCrnt = .Cells(RowSrcCrnt, ColSupplier).Value
ProductCrnt = .Cells(RowSrcCrnt, ColProduct).Value
End With
If SupplierCrnt <> "" Then
' This is the first or only row for a supplier.
' Copy it to Destination worksheet.
With WkshtSrc
.Range(.Cells(RowSrcCrnt, 1), .Cells(RowSrcCrnt, ColMax)).Copy _
Destination:=WkshtDest.Cells(RowDestCrnt, 1)
End With
RowDestCrnt = RowDestCrnt + 1
ElseIf ProductCrnt = "" Then
' Both Supplier and Product cells are empty.
With WkshtSrc
If .Cells(RowSrcCrnt, Columns.Count).End(xlToLeft).Column = 1 And _
.Cells(RowSrcCrnt, 1).Value = "" And _
.Cells(RowSrcCrnt, Columns.Count).Value = "" Then
' If you do not understand why I have so many tests,
' experiment with Ctrl+Left
' Row empty so ignore it
Else
' Don't know what to do with this error so give up
Call MsgBox("Cells " & ColSupplier & RowSrcCrnt & " and " & _
ColProduct & RowSrcCrnt & " of worksheet " & _
WkshtSrcName & _
" are blank but the entire row is not blank", _
vbOKOnly + vbCritical, "Merge rows for same supplier")
Exit Sub
End If
End With
Else
' Supplier cell is empty. Product cell is not.
' Row RowDestCrnt-1 of the Destination worksheet contains the first row
' for this supplier or the result of merging previous rows for this
' supplier.
If WkshtSrc.Cells(RowSrcCrnt + 1, ColSupplier).Value = "" And _
WkshtSrc.Cells(RowSrcCrnt + 1, ColProduct).Value <> "" Then
' The next row is for the same supplier but is not a blank row
Join = ","
Else
' This is last row for this supplier
Join = " &"
End If
' Add to list of products
With WkshtDest
.Cells(RowDestCrnt - 1, ColProduct).Value = _
.Cells(RowDestCrnt - 1, ColProduct).Value & Join & " " & _
ProductCrnt
End With
For ColCrnt = 1 To ColMax
If ColCrnt = Cells(1, ColSupplier).Column Or _
ColCrnt = Cells(1, ColProduct).Column Then
' You may think (and you may be right) that the supplier and product
' will always be in the first two columns. But have seen the
' weirdest arrangements and make no assumptions
' Ignore this column
Else
If WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = "" Then
' The most likely arrangement: the subsequent row has no
' value in this column. Nothing to do.
ElseIf WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value = "" Then
' This source row has a value in this column but [the] previous
' row[s] did not.
' Note: I use the copy statement because it copies formatting as
' well as the value which may be useful.
WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Copy _
Destination:=WkshtDest.Cells(RowDestCrnt - 1, ColCrnt)
ElseIf WkshtSrc.Cells(RowSrcCrnt, ColCrnt).Value = _
WkshtDest.Cells(RowDestCrnt - 1, ColCrnt).Value Then
' Values match. Nothing to do.
Else
' Values do not match.
' Don't know what to do with this error so give up.
Call MsgBox("The value in cell " & ColNumToCode(ColCrnt) & _
RowSrcCrnt & " of worksheet " & WkshtSrcName & _
" does not match a value in an earlier row " & _
"for the same supplier", _
vbOKOnly + vbCritical, "Merge rows for same supplier")
Exit Sub
End If
End If
Next
End If
Next
With WkshtDest
.Cells.Columns.AutoFit
End With
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
' Convert a column identifier (A, AA, etc.) to its number
Dim Code As String
Dim PartNum As Long
' Last updated 3 Feb 12. Adapted to handle three character codes.
If ColNum = 0 Then
ColNumToCode = "0"
Else
Code = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
Code = Chr(65 + PartNum) & Code
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = Code
End Function