View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Henrietta Horne Henrietta Horne is offline
external usenet poster
 
Posts: 15
Default UDF to merge duplicate rows

On Tue, 11 Jan 2011 13:49:34 -0600, "Clif McIrvin"
wrote:

"Henrietta Horne" wrote in message
.. .
Since you guys were so helpful, I hate to wear out my welcome, but...

<snip

Can I impose on someone to get this started?

The parts I am not sure how to do inside a UDF a

1. How to step through the rows and address the cells (relatively).


The working procedure I'm posting below might give you some ideas to
work with, even though I'm making no attempt to apply it to your
question <grin [since you show a desire to learn! :) ]


2. How to delete a row.

one possibility:
Range("A5").Select
Selection.EntireRow.Delete

(code the result of recording a macro while manually selecting a cell
and using the UI to delete the row)


========== begin code

Sub Copy2BreakTable()
' 1/07/11 cm remove auto-filter; use range for find
' 1/25/10 cm add auto-filter on Plant ID ... partially tested
' 08 29 09 cm disable screen updates during startup

Const newRow = 2 ' New Data row
Const lookRows = 300 ' Only search newest rows

Dim ErrNum As Variant
Dim newDate, thisDate, currentDate
Dim newPlant, newLotID
Dim x2, x$, x1$
Dim SearchBegin, SearchEnd, SearchDirection
Dim firstRow, lastRow, currentRow ' cylinder data range
'Dim bPlantFilter As Boolean

'' turn off slow screen updating during searching
' Application.ScreenUpdating = False

Dim screenUpdateState As Boolean
Dim statusBarState As Boolean
Dim calcState As XlCalculation
Dim eventsState As Boolean
Dim displayPageBreakState As Boolean

With Application
screenUpdateState = .ScreenUpdating
statusBarState = .DisplayStatusBar
calcState = .Calculation
eventsState = .EnableEvents
End With

'turn off some Excel functionality so your code runs faster
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set c = Nothing ' insure exit test is valid

If newSub() Then
' newSub returns False if activesheet not valid cylData
' copies new cylinder measurements to row newRow;
' returns with BreakTable!Data as ActiveSheet

' Look in last lookRows rows for match in LotID
' Begin search at current row; look up or down depending
' on date comparison; begin at last row if current row
' is outside of lookRows range

' gather data of interest...
newPlant = Cells(newRow, BreakTableColumns.Plant).Value
newLotID = Cells(newRow, BreakTableColumns.LotID).Value
newDate = Cells(newRow, BreakTableColumns.SampleDate).Value
Set r = Range("cylData") ' all cylinder data
firstRow = r.Row
lastRow = r.Rows.Count + firstRow - 1 'xx' marker row
SearchEnd = lastRow
SearchBegin = lastRow - lookRows
If SearchBegin < firstRow Then
SearchBegin = firstRow
End If
currentRow = Selection.Row
If currentRow < SearchBegin Or _
currentRow = SearchEnd Then
' search from the bottom up -
' new break data tends to be recent
currentRow = SearchEnd
End If

Select Case newPlant
Case "MCSS"
Case "LCP" ' special processing for LCP worksheet lotID
If Mid(newLotID, 7, 1) = "+" Then
newLotID = Left(newLotID, 7)
ElseIf Right(newLotID, 2) = "++" Then
newLotID = Left(newLotID, 6) & "++"
Else
newLotID = Left(newLotID, 6)
End If
Cells(newRow, BreakTableColumns.LotID).Value = newLotID
newLotID = "xxxx" ' force search on date
Case Else
If Right(newLotID, 1) = "+" Then
newLotID = Left(newLotID, Len(newLotID) - 1)
End If
End Select

' Prepare to search for match on LotID
' search 'up' or 'down' depending on new date

currentDate = Cells(currentRow, BreakTableColumns.SampleDate).Value
Select Case DateDiff("d", currentDate, newDate)
Case Is < 0 ' newDate is older
SearchDirection = xlPrevious
Case Is = 0 ' newDate is newer
SearchDirection = xlNext
End Select

' define search range

Set r = Range(Cells(SearchBegin, BreakTableColumns.LotID), _
Cells(SearchEnd, BreakTableColumns.LotID))
Set c = Cells(currentRow, BreakTableColumns.LotID)

Set c = r.Find(What:=newLotID, After:=c, _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=SearchDirection, _
MatchCase:=False, SearchFormat:=False)
If c Is Nothing Then 'lot not found! -- look for date
Application.Speech.Speak "Lot not found", -1, 0, -1
For x2 = SearchBegin To SearchEnd
thisDate = Cells(x2, BreakTableColumns.SampleDate).Value
If IsEmpty(thisDate) Then Exit For
Select Case DateDiff("d", thisDate, newDate)
Case Is < 0 ' thisDate is future
Exit For
Case 0 ' same date
If DatePart("h", thisDate) = 0 Then
Exit For ' No Sample time (MCSS) so stop here
End If ' else ignore time; continue search
End Select
Next x2 ' SearchBegin To SearchEnd
Set c = Cells(x2, BreakTableColumns.SampleDate)
End If ' c Is Nothing Then lot not found! -- look for date

With c ' scroll to selected row
.Show
.EntireRow.Select
End With

Select Case newPlant
Case "MCSS" 'Set MCSS Summary not printed flag
flagMCSS = True
With Selection.Cells(1, 5).Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
With Cells(4, 5)
.Value = "MCSS Summary not printed"
With .Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End With
End Select

End If

'' restore screen updates
'put this at the end of your code
With Application
.Calculation = calcState ' cancels cut/copy mode
.EnableEvents = eventsState
.DisplayStatusBar = statusBarState
.ScreenUpdating = screenUpdateState
End With

If Not c Is Nothing Then
Rows(newRow).Copy
End If

Set c = Nothing
Set r = Nothing

End Sub


Wow. I'll need a few days to digest that. Did you just type that up on
the fly or did you already have some similar code?