Exit condition not triggering in Do Until loop - vb.net

I'm trying to write an application that takes a report (Excel worksheet), manipulates a row, then goes to the next row, then the next row, etc., then exits the Do Until loop once the first two cells in the next row are empty (indicating that there are no more rows to process), like so:
Imports Excel = Microsoft.Office.Interop.Excel
Dim MSExcel As New Excel.Application
MSExcel.Visible = True
Dim WorkbookA As Excel.Workbook
Dim WorksheetA As Excel.Worksheet
Dim i As Integer = 2 'Skipping header row
Dim Split() As String
Dim SomeStrings() As String = {"StringA", "StringB"} 'etc... an array of strings
WorkbookA = MSExcel.Workbooks.Open(TextBox1.Text)
WorksheetA = WorkbookA.Sheets.Item(1)
Do Until WorksheetA.Cells(i, 1).Value = "" And WorksheetA.Cells(i, 2).Value = ""
'~~If Column A cell does not contain 'valueA' or Column E cell does not contain 'valueB', delete the row
Do Until InStr(WorksheetDisplay.Cells(i, 1).Value, "ValueA") <> 0 And InStr(WorksheetDisplay.Cells(i, 5).Value, "ValueB") <> 0 _
And InStr("somenumbershere", Strings.Left((WorksheetDisplay.Cells(i, 3).Value), 1)) <> 0 'Only keeps entries that begin with a certain number
WorksheetDisplay.Rows(i).Delete() 'Otherwise we delete the row
Loop
For Each Str As String In SomeStrings
If Str = WorksheetDisplay.Cells(i, 3).Value Then
Split = Strings.Split(WorksheetDisplay.Cells(i, 3).Value, " ")
WorksheetDisplay.Cells(i, 3).Value = Split(0) & " some text here"
End If
Next
i = i + 1
Loop
However the program never stops running.
Any idea why?

In your inner do until..loop where you are checking for three different conditions, if all 3 of those conditions are not met, your code will keep deleting the top row of the worksheet. This causes Excel to keep adding rows to the bottom of the worksheet.
So, this inner do loop has the potential to run forever, preventing the outer do loop from ever evaluating the existence of blank cells. A better arrangement of logic might be:
Do Until WorksheetA.Cells(i, 1).Value = "" And WorksheetA.Cells(i, 2).Value = ""
If InStr(WorksheetDisplay.Cells(i, 1).Value, "ValueA") <> 0 And InStr(WorksheetDisplay.Cells(i, 5).Value, "ValueB") <> 0 _
And InStr("somenumbershere", Strings.Left((WorksheetDisplay.Cells(i, 3).Value), 1)) <> 0 'Only keeps entries that begin with a certain number
WorksheetDisplay.Rows(i).Delete() 'Otherwise we delete the row
'Decrement i so that the row that used to be beneath the row just deleted is not skipped.
i = i - 1
Else
For Each Str As String In SomeStrings
If Str = WorksheetDisplay.Cells(i, 3).Value Then
Split = Strings.Split(WorksheetDisplay.Cells(i, 3).Value, " ")
WorksheetDisplay.Cells(i, 3).Value = Split(0) & " some text here"
End If
Next
End If
i = i + 1
Loop
I haven't run this code, since I don't know what kind of dataset you have to test against; but basically, if you delete a row, you need to get back to the outer do loop to check if you have run out of data, and stop execution if you have.

Related

Remove Duplicates, concatenated, from the top

I have coded following macro, it is working when I save the values to immediate window, but don't know how to populate the values, delimited with "," into one cell. Basically I look for "Active" in a column, and if found, go 4 cells to the left and take the info from there...
Could you help please?
Dim Active() As Variant
Dim i
ReDim Active(Range("G9:G24").Cells.Count)
For Each Zelle In Range("G9:G24")
If InStr(1, Zelle, "Active") <> 0 Then
Active(i) = Zelle.Offset(0, -4)
End If
i = i + 1
Next Zelle
For i = LBound(Active) To UBound(Active)
If Trim(Active(i)) <> "" Then
Debug.Print Active(i)
End If
Next i
End Sub
Add the following
Dim s As String
Then rewrite the loop like this:
For i = LBound(Active) To UBound(Active)
If Trim(Active(i)) <> "" Then
s = s & IIf(Len(s)>0, ",", "") & trim(Active(i))
End If
Next i
Then you can assign s to a cell.
you can greatly shorten your code by looping through wanted range cells corresponding to not-blank cells only in column C
Dim Zelle As Range
Dim resultStrng As String
For Each Zelle In Range("G9:G24").Offset(,-4).SpecialCells(xlCellTypeConstants) '<--| loop through not blank cell in range 4 columns to the left of G9:G24
If InStr(1, Zelle.Offset(, 4), "Active") <> 0 And Trim(Zelle) <> "" And Instr(resultStrng, Trim(Zelle)) =0 Then resultStrng = resultStrng & Trim(Zelle) & "," '<--| update your result string whenever current cell has a character and its 4 columns to the right offset cell meets the "Active" criteria
Next Zelle
If resultStrng <> "" Then resultStrng = Left(resultStrng, Len(resultStrng) - 1) '<-- remove the last comma from 'resultStrng'

Referencing a particular cell value when there are two string matches in VBA

I am trying to create a predictive algorithm in VBA that would search for strings in a particular row from a data source, and return a value based on the row number. This is the first step in the workflow, and in its simplest form, there are 2 tables as shown below:
Source Table:
Output Table:
This is what I'm trying to do:
Pick up the strings in Row 1 of Output Table (Blue,Black) and search for them in Rows 1,2,3,4 of Source Table.
If both strings match in a single row, the 'Input' cell from that particular row is copied to Row 1 in Output Table in the 'Output' column.
Example (2nd iteration):
From Output Table Row 2, strings Ivory,Green,Grey are picked up and queried in all rows of Source Table. If any 2 out of 3 strings match in a single row on Source Table, the Input cell of that row is copied.
In this case, Ivory and Green match in Row 1, and also in Row 4. Either input cell would work, but for the sake of having a rule, lets take the last match (Row 4). So '1,8' would be copied to Row 2 on Output Table.
This the flow I am currently using, but I'm getting an incorrect output:
For i = 2 To 5
For j = 1 To 4
For k = 2 To 5
For l = 1 To 5
If Cells(i, j).Value = Worksheets("SourceTable").Cells(k, l).Value And Cells(i,j).Value <> "" Then
For a = 1 To 5
For b = 1 To 4
If Cells(i, b).Value = Worksheets("SourceTable").Cells(k, a).Value And Cells(i, b).Value <> "" Then
Cells(i, 15).Value = Worksheets("SourceTable").Cells(k, 5).Value
GoTo iLoop
End If
Next b
Next a
End If
Next l
Next k
Next j
iLoop:
Next i
Both tables would have around half a million rows, and I am trying to figure out how to reduce the number of loops and make it work at the same time. Any suggestions would be appreciated, this would help me save a lot of man-hours and automate a major chunk of the process. Thanks!
Sub macro()
lastRowOut = Sheets("OutputTable").Range("A" & Rows.Count).End(xlUp).Row
lastRowSou = Sheets("SourceTable").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRowOut
For j = 2 To lastRowSou
If checkRow(j, i) >= 2 Then
Sheets("OutputTable").Cells(i, 5) = Sheets("SourceTable").Cells(j, 6)
Exit For
End If
Next j
Next i
End Sub
Function checkRow(sRow, i)
lastCol = Split(Sheets("OutputTable").Cells(i, Columns.Count).End(xlToLeft).Address, "$")(1)
counter = 0
For Each cell In Sheets("OutputTable").Range("A" & i & ":" & lastCol & i)
If Not Sheets("SourceTable").Range("A" & sRow & ":" & "E" & sRow).Find(cell.Value) Is Nothing Then
counter = counter + 1
End If
Next cell
checkRow = counter
End Function
Quite a few things are unclear so here were the assumptions I made:
Two or more of the cells in a row in the OutputTable have to be matched for the prediction to be made.
The first rows of both the Output and Source sheet contain "Col1, Col2" etc.
You seem to not mind whether we use the first or last matching row (from the source sheet) so I went with the first.
That's 3 loops instead of 6..
you can try this
Option Explicit
Sub main()
Dim row As Range
With Worksheets("OutputTable")
For Each row In .Range("D2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "D" to "OutputTable" sheet last "col" column index (i.e. the one before "Output" column)
SearchSource row
Next
End With
End Sub
Sub SearchSource(rng As Range)
Dim cell As Range, row As Range
Dim nFounds As Long
With Worksheets("SourceTable")
For Each row In .Range("E2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "E" to "SourceTable" sheet last "col" column index (i.e. the one before "Input" column)
nFounds = 0
For Each cell In rng.SpecialCells(xlCellTypeConstants)
If Not row.Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then nFounds = nFounds + 1
If nFounds = 2 Then Exit For
Next
If nFounds = 2 Then rng.Cells(, rng.Columns.count + 1).Value = row.Cells(, row.Columns.count + 1).Value
Next
End With
End Sub
'Try this:
'First declare some variables:
'the number of rows of the Output table
Dim OrNum as integer
'the number of columns of the Output table
Dim OcNum as integer
'the number of rows of the Source table
Dim SrNum as integer
'the number of columns of the Source table
Dim ScNum as integer
'some dummy variables for the loops
Dim rO as integer, cO as integer
Dim rS as integer, cS as integer
And then declare a boolean variable (just for later on)
Dim bool as boolean
'Then assume the output table has it's first cell at the most 'top and the most left of the output table, which is taken to 'be the cell Z1 in the following Code
'Begin with this first cell of the Output table and get each 'value in a way, that you move first (inner loop) over the 'columns by fixing the row Index (rO) of the Output table and then (outer loop) get down to each and every row like this:
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
Range("Z1").Offset(rO, cO)
Next
Next
'Now you don't have only strings so you will need to check, 'if the value in the cell is a string or a number. There is VBA 'function, that can help. It's called IsNumeric. It will give 'True if the value is a numeric value. If we have a string, then it will give False. With the Function IsEmpty() you can also check if a cell is empty or not. If a cell is empty, then the function IsEmpty will return True.
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
bool = IsNumeric(Range("Z1").Offset(rO, cO).Value)
bool = bool Or IsEmpty (Range("Z1").Offset(rO, cO).Value)
If bool=False then
'we have a string!
'do something
End if
Next
Next

Copy rows based on multiple cells values

I'm trying to copy rows from a significant amount of worksheets.
I have multiple lines that relate to a certain document, depending on the versions.
Therefore, some lines have the same reference, same name but a different version/date of creation. I'd like to copy to another sheet (Sheet2 for instance) the latest version of every document.
I've tried so far with a few while loops to check all lines and a if to check the value of the date but I failed to make it work, and I wonder if it's an efficient way of doing it.
Here is a picture of my problem and a part of the code I wrote :
Dim Name as String
Dim Dates as Date
With Sheets(Sheet1)
Application.DisplayAlerts = False
Name = Cells(1,3) 'Initialise Name
Dates = Cells(1,5) 'Initialise Dates
LineCopy = 1 'The line we'll copy
Line = 1 'The line we use to check the sheet
While Name <> "" 'if the name is not empty, ie there are no documents left
While Sheets(Sheet1).StrComp(Name, .Cells(Line, 3)) = True 'WHile you are working with a same name document
If .Cells(Line, 5) > Dates Then 'If the document is older, then choose it.
Dates = .Cells(Line, 5)
Else
LineCopy = Line 'If there are no older documents, then it's the one to copy
Sheets(Sheet1).Range("A" & LineCopy & ":" & "E" & LineCopy).Copy ' Copy the oldest document
Sheets(Sheet2).Paste
End If
Line = Line + 1 ' Increment the Line in the second while to check every line
Wend
Name = .Cells(LineCopy + 1, 6) 'After the first while, let's change name to the second document and do it all over again.
Wend
Unless you need the formating I think copy and paste should be avoided.
The below code assumes the data is sorted on column A. If not another aproach is needed.
Edit: Adapted to comment that there may be blank rows.
Dim max_date As Date
Dim max_row As Long
Dim old_sheet As Worksheet
Dim new_sheet As Worksheet
Dim counter As Long
Dim last_name as String
Set new_sheet = Sheets("Sheet2") 'adjust name to result sheet
counter = 1
For x = 1 To 5 ' the sheets you should loop thru
Set old_sheet = Sheets(x)
end_row = old_sheet.Cells(old_sheet.Rows.Count, 1).End(xlUp).Row
For i = 2 To end_row 'loop all rows
If old_sheet.Cells(i, 5) > max_date Then 'if the date is larger, sve the date and the row
max_date = old_sheet.Cells(i, 5)
max_row = i
End If
if old_sheet.cells(i,j)<>"" then last_name = old_sheet.cells(i,j)
If (old_sheet.Cells(i + 1, 1) <> "" and old_sheet.Cells(i + 1, 1) <> last_name) or i = end_row Then
For j = 1 To 4
new_sheet(counter, j) = old_sheet(max_row, j) 'add the data to the new sheet
Next j
max_date = DateValue("01/01/1970") 'reset the date value
counter = counter + 1 'new row to move the data to
End If
Next i
Next x

Compare and copy matching data from adjacent cells

I was having some trouble with a macro I have been writing. I am trying to find a match in column A and column D. When I detect a match I want to copy the adjacent cells of each I.E copy the contents of B of the line of the first match to E where the match occurs in D. Whenever I do this I never get the right copy. It will copy the values that match but put them in the completely wrong space. I only encounter a problem when the order is mixed up or there is a white space. Any suggestions would be helpful.
Thanks
Nick.
Note: In this version of my code I was using input boxes to pick what two columns of data the user wants to compare and the one he wants to copy from and paste too. It should not make a big difference.
Sub Copy()
Dim column1 As String
Dim column2 As String
Dim from As String
Dim too As String
numrows = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
'MsgBox numrows
column1 = InputBox("which column do you want to select from")
column2 = InputBox("which column do you want to compare to ")
from = InputBox("which column do you want to copy data from")
too = InputBox("which column do you want to copy data to")
Dim lngLastRow As Long
Dim lngLoopCtr As Long
Dim i As Long
Dim j As Long
Dim value As String
lngLastRow = Range(column1 & Rows.Count).End(xlUp).Row
lngLastRow2 = Range(column2 & Rows.Count).End(xlUp).Row
'lngLastRow = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
Dim temp As String
For i = 1 To lngLastRow Step 1
temp = Cells(i, column1).value
value = Cells(i, from).value
'MsgBox "temp"
'MsgBox (temp)
If Cells(i, column1).value <> "" Then
For j = 1 To lngLastRow2 Step 1
' MsgBox "cell"
' MsgBox (Cells(j, column2).value)
If Cells(j, column2).value = "" Then
Cells(j, column2).Offset(1, 0).Select
End If
If Cells(j, column2).value <> "" Then
If temp = Cells(j, column2).value Then
'MsgBox "equal"
'MsgBox "i"
'MsgBox i
'MsgBox "j"
'MsgBox j
'value = Cells(j, from).value
'MsgBox Cells(i, too).value
'Cells(i, too).value = Cells(j, from).value
'Dim num As Integer
'On Error Resume Next
'num = Application.WorksheetFunction.VLookup(temp, Sheet1.Range("A0:M13"), 3, False)
Cells(i, too).value = Cells(j, from).value
'MsgBox j
' MsgBox (Cells(i, column1).value)
' MsgBox "="
' MsgBox (Cells(j, column2).value)
End If
End If
Next j
End If
Next i
End Sub
I have studied your text and your macro and think the macro below does what you want.
If this macro does what you want, your problem was caused by your use of meaningless variable names such as: column1, column2, i and j. This meant you did not notice you were using the wrong variables in the statement that copied values.
I have renamed all your variables. I am not asking you to like my naming convention but I am recommending you have a naming convention. I can look at macros I wrote years ago and know what all the variables are because I developed my convention in my early days of VBA programming and have used it every since. This makes my life much easier when I need to update old macros.
I have added Option Explicit at the top of the module. Without this statement, a misspelt variable name becomes a declaration:
Dim Count As Long
Lots of statements
Count = Conut + 1
This causes Conut to be declared with a value of zero. Such errors can be a nightmare to find.
I have used a With Statement to make explicit which worksheet I am using.
You checked both cells to not be empty. I only check the first because it is not necessary to check the second since, if the second is empty, it will not match the first.
Your code did not stop working down the Compare column if it found a match so my code does the same. This is correct if values can repeat in the Compare column. If they cannot repeat, you may wish to add Exit For to exit the inner loop after a match has been processed.
I believe the above explains all the changes I hve made.
Option Explicit
Sub Copy()
Dim ColCompare As String
Dim ColCopyFrom As String
Dim ColCopyTo As String
Dim ColSelect As String
Dim RowCrntCompare As Long
Dim RowCrntSelect As Long
Dim RowLastColCompare As Long
Dim RowLastColSelect As Long
Dim SelectValue As String
With Sheet1
ColSelect = InputBox("which column do you want to select ColCopyFrom")
ColCompare = InputBox("which column do you want to compare to ")
ColCopyFrom = InputBox("which column do you want to copy data ColCopyFrom")
ColCopyTo = InputBox("which column do you want to copy data to")
RowLastColSelect = .Range(ColSelect & .Rows.Count).End(xlUp).Row
RowLastColCompare = .Range(ColCompare & .Rows.Count).End(xlUp).Row
For RowCrntSelect = 1 To RowLastColSelect Step 1
SelectValue = .Cells(RowCrntSelect, ColSelect).value
If SelectValue <> "" Then
For RowCrntCompare = 1 To RowLastColCompare Step 1
If SelectValue = Cells(RowCrntCompare, ColCompare).value Then
.Cells(RowCrntCompare, ColCopyTo).value = _
.Cells(RowCrntSelect, ColCopyFrom).value
End If
Next RowCrntCompare
End If
Next RowCrntSelect
End With
End Sub

Merge cells and delete duplicate data

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
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