PDA

View Full Version : Solved: Number unique numbers in list (cells as checkboxes)



IgnBan
03-04-2008, 08:29 AM
One more request on same form. How can I number the number of units that ?Needs Repair? on Sheet2 column ?A?? I want to link this information to an existing summary sheet where it will show ; #?s?Units? with #?s discrepancies needs repair. Can this code be modify to show the number on Units in column ?A??
See attached workbook Sheet2 intended format.

Private Sub Worksheet_Activate()
Dim mpLastRow As Long
Dim mpNextRow As Long
Dim mpTargetRow As Long

mpLastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
With Me.Rows("2:" & mpLastRow + 50)

.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
.ClearContents
.Font.Bold = False
End With

mpNextRow = 4
With Worksheets("Sheet1")

mpTargetRow = 2
For Each mpRow In .UsedRange.Rows

If mpRow.Cells(1, "B").Value = "Needs Repair" Then

mpRow.Cells(1, "B").Resize(, 3).Copy
Me.Cells(mpNextRow, "A").PasteSpecial Paste:=xlPasteValues
If Me.Cells(mpNextRow, "B").Value <> Me.Cells(mpNextRow - 1, "B").Value Then

Me.Cells(mpNextRow, "A").Resize(, 3).Font.Bold = True
End If
mpNextRow = mpNextRow + 1
End If
Next mpRow
End With

mpLastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
If mpLastRow > 1 Then

With Me.Range("A1").Resize(mpLastRow, 3)

.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End If

Me.Range("A1").Select
End Sub

Bob Phillips
03-04-2008, 09:41 AM
Private Sub Worksheet_Activate()
Dim mpLastRow As Long
Dim mpNextRow As Long
Dim mpTargetRow As Long

mpLastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
With Me.Rows("2:" & mpLastRow + 50)

.Borders(xlLeft).LineStyle = xlNone
.Borders(xlRight).LineStyle = xlNone
.Borders(xlTop).LineStyle = xlNone
.Borders(xlBottom).LineStyle = xlNone
.ClearContents
.Font.Bold = False
End With

mpNextRow = 4
With Worksheets("Sheet1")

mpTargetRow = 2
For Each mpRow In .UsedRange.Rows

If mpRow.Cells(1, "B").Value = "Needs Repair" Then

mpRow.Cells(1, "B").Resize(, 3).Copy
Me.Cells(mpNextRow, "B").PasteSpecial Paste:=xlPasteValues
If Me.Cells(mpNextRow, "C").Value <> Me.Cells(mpNextRow - 1, "C").Value Then

Me.Cells(mpNextRow, "A").Value = _
Application.Max(Me.Range(Me.Range("A1"), Me.Cells(mpNextRow, "A").Offset(-1, 0))) + 1
Me.Cells(mpNextRow, "A").Resize(, 4).Font.Bold = True
End If
mpNextRow = mpNextRow + 1
End If
Next mpRow
End With

mpLastRow = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row
If mpLastRow > 1 Then

With Me.Range("A1").Resize(mpLastRow, 4)

.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End If

Me.Range("A1").Select
End Sub


Why do you have textboxes in your headings on Sheet2?

IgnBan
03-04-2008, 11:02 AM
Works perfect! counting the Units will make a great complement to my summary Sheet.
Thanks again Xld! :thumb