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