Excel Workbook | ||||||
---|---|---|---|---|---|---|
A | B | C | D | |||
1 | Company | Company | Count | |||
2 | Company 1 | Company 1 | 2 | |||
3 | Company 2 | Company 2 | 3 | |||
4 | Company 1 | Company 3 | 2 | |||
5 | Company 2 | |||||
6 | Company 3 | |||||
7 | Company 2 | |||||
8 | Company 3 | |||||
9 | ||||||
Count |
JimHi Peter,
It worked great thank you very much,,, I have one other one if you can..
I want to make a drop down calendar for my work sheet, I tried to use a add-in but it does not work with my Mac version of Excel..
Thanks again
Jim
' in a normal module
Option Explicit
Sub MakeUserForm()
Dim LIndex As Long, TIndex As Long
Dim Linterval As Long, Tinterval As Long
Dim oneName As Variant
Dim NumSize As Long, HeadSize As Long, EnterSize As Long
Dim FontName As String
Dim i As Long
FontName = "Arial"
NumSize = 18
HeadSize = 10
EnterSize = 14
Linterval = 32
Tinterval = 27
With ThisWorkbook.VBProject.VBComponents("macDate")
.Name = "macDate"
With .Designer
.Controls.Clear
Rem array of day label
With .Controls.Add("Forms.Frame.1", Name:="frameDays")
.Top = 10: .Left = 10
.Height = 200: .Width = 200
Rem days frame styling
' .AutoSize = True
.BackColor = .Parent.BackColor
.BorderStyle = fmBorderStyleSingle
.TabStop = False
.SpecialEffect = fmSpecialEffectFlat
.Caption = vbNullString
'<<<<<<<<<<
Rem add Mon,Tue.. headers
With .Controls.Add("Forms.Frame.1", Name:="frameDayHeaders")
Rem days frame styling
.BackColor = .Parent.BackColor
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Caption = vbNullString
.TabStop = False
Rem day headers
LIndex = -1: TIndex = 0
For Each oneName In Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
LIndex = LIndex + 1: If LIndex > 6 Then TIndex = TIndex + 1: LIndex = 0
With .Controls.Add("Forms.Label.1", Name:="lbl" & oneName)
.BackColor = RGB(127, 127, 127)
.BackStyle = fmBackStyleTransparent
.BorderColor = RGB(50, 50, 50)
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Height = 12: .Width = 24
.WordWrap = False
.TextAlign = fmTextAlignCenter
With .Font
.Name = FontName
.Size = HeadSize
End With
.Caption = oneName
.Height = 12
.AutoSize = True
.Top = TIndex * Tinterval + 3
.Left = LIndex * Linterval + 4
End With
Next oneName
.Top = 30
.Height = .Controls(1).Height + 3
.Left = 0
.Width = .Controls(.Controls.Count - 1).Left + .Controls(.Controls.Count - 1).Width + 6
End With
With .Controls.Add("forms.Label.1", Name:="lblMonthYear")
.BackColor = .Parent.BackColor
.BackStyle = fmBackStyleTransparent
.BorderColor = RGB(0, 0, 0)
.BorderStyle = fmBorderStyleSingle
With .Font
.Name = FontName
.Size = EnterSize
End With
.WordWrap = False
.TextAlign = fmTextAlignCenter
.AutoSize = True
.Caption = "September 2828"
.AutoSize = False
.Width = .Width + 20
End With
With .Controls.Add("forms.Label.1", Name:="lblPrevMonth")
.BackColor = RGB(150, 150, 150)
.BackStyle = fmBackStyleOpaque
.BorderColor = RGB(0, 0, 0)
.BorderStyle = fmBorderStyleSingle
With .Font
.Name = FontName
.Size = EnterSize
End With
.WordWrap = False
.TextAlign = fmTextAlignCenter
.AutoSize = True
.Caption = "<"
.AutoSize = False
.Width = .Height
End With
With .Controls.Add("forms.Label.1", Name:="lblPrevYear")
.BackColor = .Parent.Controls("lblPrevMonth").BackColor
.BackStyle = fmBackStyleOpaque
.BorderColor = RGB(0, 0, 0)
.BorderStyle = fmBorderStyleSingle
With .Font
.Name = FontName
.Size = EnterSize
End With
.WordWrap = False
.TextAlign = fmTextAlignCenter
.AutoSize = True
.Caption = "<<"
.AutoSize = False
'.Width = .Height
End With
With .Controls.Add("forms.Label.1", Name:="lblNextMonth")
.BackColor = .Parent.Controls("lblPrevMonth").BackColor
.BackStyle = fmBackStyleOpaque
.BorderColor = RGB(0, 0, 0)
.BorderStyle = fmBorderStyleSingle
With .Font
.Name = FontName
.Size = EnterSize
End With
.WordWrap = False
.TextAlign = fmTextAlignCenter
.AutoSize = True
.Caption = ">"
.AutoSize = False
.Width = .Height
End With
With .Controls.Add("forms.Label.1", Name:="lblNextYear")
.BackColor = .Parent.Controls("lblPrevMonth").BackColor
.BackStyle = fmBackStyleOpaque
.BorderColor = RGB(0, 0, 0)
.BorderStyle = fmBorderStyleSingle
With .Font
.Name = FontName
.Size = EnterSize
End With
.WordWrap = False
.TextAlign = fmTextAlignCenter
.AutoSize = True
.Caption = ">>"
.AutoSize = False
'.Width = .Height
End With
Rem add day labels
LIndex = -1: TIndex = 0
For i = 1 To 35
LIndex = LIndex + 1: If LIndex > 6 Then TIndex = TIndex + 1: LIndex = 0
With .Controls.Add("Forms.Label.1", Name:="lblDay" & i)
.BackColor = RGB(127, 127, 200)
.BorderColor = RGB(50, 50, 50)
.BorderStyle = fmBorderStyleSingle
.SpecialEffect = fmSpecialEffectFlat
.Height = 23: .Width = 23
.WordWrap = False
.TextAlign = fmTextAlignCenter
With .Font
.Name = FontName
.Size = NumSize
End With
.Caption = Format(i, "0")
.Top = .Parent.Controls("frameDayHeaders").Top + .Parent.Controls("frameDayHeaders").Height _
+ TIndex * Tinterval + 4
.Left = LIndex * Linterval + 4
End With
Next i
.Height = .Controls(.Controls.Count - 1).Top + .Controls(.Controls.Count - 1).Height + 6
.Width = .Controls(.Controls.Count - 1).Left + .Controls(.Controls.Count - 1).Width + 6
With .Controls("lblMonthYear")
.Top = 5
.Left = .Parent.Width / 2 - .Width / 2
End With
With .Controls("lblPrevMonth")
.Top = .Parent.Controls("lblMonthYear").Top
.Left = .Parent.Controls("lblMonthYear").Left - .Width - 5
End With
With .Controls("lblPrevYear")
.Top = .Parent.Controls("lblMonthYear").Top
.Left = .Parent.Controls("lblPrevMonth").Left - .Width - 2
End With
With .Controls("lblNextMonth")
.Top = .Parent.Controls("lblMonthYear").Top
.Left = .Parent.Controls("lblMonthYear").Left + .Parent.Controls("lblMonthYear").Width + 5
End With
With .Controls("lblNextYear")
.Top = .Parent.Controls("lblMonthYear").Top
.Left = .Parent.Controls("lblNextMonth").Left + .Parent.Controls("lblNextMonth").Width + 2
End With
End With
Rem add manual entry controls
With .Controls.Add("Forms.Frame.1", Name:="frameUserEntryControls")
With .Controls.Add("Forms.ComboBox.1", Name:="cbxDays")
.ShowDropButtonWhen = fmShowDropButtonWhenFocus
.SpecialEffect = fmSpecialEffectFlat
With .Font
.Name = FontName
.Size = EnterSize
End With
.TextAlign = fmTextAlignRight
.AutoSize = True
.Text = "01"
.AutoSize = False
.Width = .Width + 20
.Top = 1
.Left = 1
End With
With .Controls.Add("Forms.ComboBox.1", Name:="cbxMonths")
.ShowDropButtonWhen = fmShowDropButtonWhenFocus
.SpecialEffect = fmSpecialEffectFlat
With .Font
.Name = FontName
.Size = EnterSize
End With
.TextAlign = fmTextAlignLeft
.AutoSize = True
.Text = "September"
.AutoSize = False
.Width = .Width + 22
.ListRows = 12
.Top = .Parent.Controls("cbxDays").Top
.Left = .Parent.Controls("cbxDays").Left + .Parent.Controls("cbxDays").Width + 1
End With
With .Controls.Add("Forms.TextBox.1", Name:="tbxYear")
.ShowDropButtonWhen = fmShowDropButtonWhenNever
.SpecialEffect = fmSpecialEffectFlat
With .Font
.Name = FontName
.Size = EnterSize
End With
.TextAlign = fmTextAlignLeft
.AutoSize = True
.Text = "2011"
.AutoSize = False
.Width = .Width + 4
.Top = .Parent.Controls("cbxMonths").Top
.Left = .Parent.Controls("cbxmonths").Left + .Parent.Controls("cbxmonths").Width + 1
End With
.BackColor = .Parent.BackColor
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Height = .Controls("cbxDays").Height + 3
.Width = .Controls("tbxYear").Left + .Controls("tbxYear").Width - .Controls("cbxDays").Left
.Top = .Parent.Controls("frameDays").Top + .Parent.Controls("frameDays").Height + 5
.Left = .Parent.Controls("frameDays").Left + .Parent.Controls("frameDays").Width / 2 - .Width / 2
End With
Rem add command buttons
With .Controls.Add("Forms.CommandButton.1", Name:="butCancel")
With .Font
.Name = FontName
.Size = EnterSize
End With
.Caption = "Cancel"
.TabStop = False
.AutoSize = True
.AutoSize = False
.Height = .Height - 4
.Width = .Width + 20
.Top = 200
.Left = .Parent.Controls("frameDays").Left + .Parent.Controls("frameDays").Width + 10
.Top = .Parent.Controls("frameDays").Top + .Parent.Controls("frameDays").Height - 3 * .Height
End With
With .Controls.Add("Forms.CommandButton.1", Name:="butOK")
With .Font
.Name = FontName
.Size = EnterSize
End With
.Caption = "OK"
.Default = True
.Height = .Parent.Controls("butCancel").Height
.Width = .Parent.Controls("butCancel").Width
.Left = .Parent.Controls("frameDays").Left + .Parent.Controls("frameDays").Width + 10
.Top = .Parent.Controls("frameDays").Top + .Parent.Controls("frameDays").Height - .Height
End With
End With
End With
End Sub
' in userform code module
Option Explicit
Dim DayLabels As Collection
Private Sub butCancel_Click()
Unload Me
End Sub
Public Sub butOK_Click()
Me.Hide
End Sub
Private Sub UserForm_Activate()
Dim oneDay As clsDayLabel
Dim oneLabel As MSForms.Control
Dim oneEntry As Variant
With Me
.Height = .frameUserEntryControls.Top + .frameUserEntryControls.Height + 35
.Width = .butCancel.Left + .butCancel.Width + 10
.Tag = "shown"
End With
With Me.cbxMonths
For oneEntry = 1 To 12
.AddItem Format(DateSerial(1, oneEntry, 20), "mmmm")
Next oneEntry
End With
For Each oneLabel In Me.frameDays.Controls
If oneLabel.Name Like "lblDay*" Then
Set oneDay = New clsDayLabel
Set oneDay.dLabel = oneLabel
DayLabels.Add Item:=oneDay, Key:=oneLabel.Name
End If
Next oneLabel
Set oneDay = Nothing
If DateDisplayed < 0 Then DisplayDate Date
DisplayDate DateDisplayed
ShowMonth DateDisplayed
End Sub
Private Sub UserForm_Initialize()
Set DayLabels = New Collection
frameDays.SetFocus
End Sub
Private Sub UserForm_Terminate()
Dim oneObj As clsDayLabel
For Each oneObj In DayLabels
Set oneObj = Nothing
Next oneObj
Set DayLabels = Nothing
End Sub
Function DateDisplayed(Optional DaySet As Long) As Date
Rem return date shown in cbxDays cbxMonths tbxYear
If DaySet < 0 Then
DaySet = 1
Else
DaySet = Val(cbxDays.Text)
End If
If IsDate(DaySet & " " & cbxMonths.Text & ", " & tbxYear.Text) Then
DateDisplayed = DateValue(DaySet & " " & cbxMonths.Text & ", " & tbxYear.Text)
Else
DateDisplayed = -1
End If
End Function
Public Sub DisplayDate(aDate As Date)
Rem fill cbxDays cbxMonths tbxYear
tbxYear = Format(aDate, "yyyy")
cbxMonths = Format(aDate, "mmmm")
cbxDays = Format(aDate, "d")
End Sub
Private Sub ValidateManualEntry(aControl As Object)
Rem has the user entered a valid month?
Rem eg. "31 Feb 2002" ?
Dim ddate As Date, dFormat As String
Select Case aControl.Name
Case "tbxYear"
dFormat = "yyyy"
Case "cbxMonths"
dFormat = "mmmm"
Case "cbxDays"
dFormat = "d"
End Select
ddate = DateDisplayed
With aControl
If 0 < ddate Then
.Text = Format(ddate, dFormat)
Else
.Text = .Tag
Beep
End If
End With
Call ShowMonth(DateDisplayed)
End Sub
Public Sub ShowMonth(startDate As Date)
Rem show full month
Dim baseDate As Date, dateOffset As Long
Dim muteColor As Double, thisColor As Double
muteColor = RGB(100, 100, 120)
Dim ddate As Date, i As Long
If 0 < startDate Then
baseDate = DateSerial(Year(startDate), Month(startDate), 1)
dateOffset = CLng(baseDate - DateValue("1/7/1900")) Mod 7
End If
thisColor = muteColor
With frameDays
.lblMonthYear = Format(baseDate, "mmmm yyyy")
For i = 1 To 35
ddate = baseDate - dateOffset + i - 1
If Day(ddate) = 1 Then
If thisColor = 0 Then thisColor = muteColor Else thisColor = 0
End If
With .Controls("lblDay" & i)
.Caption = Format(ddate, "d")
.Tag = CStr(CDbl(ddate))
If CStr(CDbl(DateDisplayed)) = .Tag Then
.ForeColor = thisColor
.BackStyle = fmBackStyleOpaque
.BorderStyle = fmBorderStyleNone
Else
.ForeColor = thisColor
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
End If
End With
Next i
End With
End Sub
Rem next/prevous month/year clicks
Private Sub lblNextMonth_Click()
Dim ddate As Date
ddate = DateValue("1 " & lblMonthYear)
Call ShowMonth(DateSerial(Year(ddate), Month(ddate) + 1, 1))
End Sub
Private Sub lblNextYear_Click()
Dim ddate As Date
ddate = DateValue("1 " & lblMonthYear)
Call ShowMonth(DateSerial(Year(ddate) + 1, Month(ddate), 1))
End Sub
Private Sub lblPrevMonth_Click()
Dim ddate As Date
ddate = DateValue("1 " & lblMonthYear)
Call ShowMonth(DateSerial(Year(ddate), Month(ddate) - 1, 1))
End Sub
Private Sub lblPrevYear_Click()
Dim ddate As Date
ddate = DateValue("1 " & lblMonthYear)
Call ShowMonth(DateSerial(Year(ddate) - 1, Month(ddate), 1))
End Sub
Rem <end> end/previous month/year clicks
Rem user entry control routines
Private Sub cbxDays_Enter()
Dim i As Long, ddate As Date, dText As String
ddate = DateDisplayed(-1)
If 0 < ddate Then
With cbxDays
dText = .Text
.Tag = dText
.Clear
For i = 1 To Day(DateSerial(Year(ddate), Month(ddate) + 1, 0))
.AddItem i
Next i
If .ListCount < Val(dText) Then dText = CStr(.ListCount)
.ListRows = .ListCount
.Text = dText
.SelStart = 0
.SelLength = Len(dText)
.DropDown
End With
End If
End Sub
Private Sub cbxDays_AfterUpdate()
Call ValidateManualEntry(cbxDays)
End Sub
Private Sub cbxMonths_Enter()
With cbxMonths
.Tag = .Text
.DropDown
End With
End Sub
Private Sub cbxMonths_AfterUpdate()
Call ValidateManualEntry(cbxMonths)
End Sub
Private Sub tbxYear_Enter()
With tbxYear
.Tag = .Text
End With
End Sub
Private Sub tbxYear_AfterUpdate()
Call ValidateManualEntry(tbxYear)
End Sub
Rem <end> user entry control routines
Public Function Chosen(Optional Default As Date, Optional Title As String = "Choose Date") As Double
If Default = 0 Then Default = Date
With Me
.DisplayDate Default
.Caption = Title
.Show
End With
With macDate
If .Tag = "shown" And (0 < .DateDisplayed) Then
Chosen = .DateDisplayed
Else
Chosen = 0
End If
End With
Unload macDate
End Function
' in class module clsDayLabel
Option Explicit
Public WithEvents dLabel As MSForms.Label
Private Property Get UserForm() As Object
Dim anObj As Object
Set anObj = dLabel
On Error GoTo ErrorHalt
Do Until anObj.Parent.Name = anObj.Name
Set anObj = anObj.Parent
Loop
ErrorHalt:
Set UserForm = anObj
End Property
Private Sub Class_Terminate()
Set dLabel = Nothing
End Sub
Private Sub dLabel_Click()
With UserForm
.DisplayDate CDate(Val(dLabel.Tag))
.ShowMonth CDate(Val(dLabel.Tag))
.butOK.SetFocus
End With
End Sub
Private Sub dLabel_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = True
UserForm.butOK_Click
End Sub
Dim uiDate As Double
uiDate = macDate.Chosen()
If uiDate = False Then
MsgBox "canceled"
Else
MsgBox "You choose " & Format(uiDate, "d mmm. yyyy")
End If