#1
|
|||
|
|||
Hi I have a VBA code that allows me to use combo boxes to pick data from a second sheet and place it into the cell, this allows me to have a larger font size and a longer pick list than the default excel pick list.
that code is Code:
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim ws As Worksheet Dim str As String Dim i As Integer Dim rngDV As Range Dim rng As Range Dim strMsg As String Dim lRsp As Long strMsg = "Add this item to the list?" If Target.Count > 1 Then Exit Sub Set ws = Worksheets("Lists") If Target.Row > 1 Then On Error Resume Next Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation) On Error GoTo 0 If rngDV Is Nothing Then Exit Sub If Intersect(Target, rngDV) Is Nothing Then Exit Sub If Target = "" Then Exit Sub str = Target.Validation.Formula1 str = Right(str, Len(str) - 1) On Error Resume Next Set rng = ws.Range(str) On Error GoTo 0 If rng Is Nothing Then Exit Sub If Application.WorksheetFunction _ .CountIf(rng, Target.Value) Then Exit Sub Else lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?") If lRsp = vbYes Then i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1 ws.Cells(i, rng.Column).Value = Target.Value rng.Sort Key1:=ws.Cells(1, rng.Column), _ Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End If End If End If End Sub Private Sub TempCombo_KeyDown(ByVal _ KeyCode As MSForms.ReturnInteger, _ ByVal Shift As Integer) On Error Resume Next Dim ws As Worksheet Dim str As String Dim i As Integer Dim rngDV As Range Dim rng As Range Dim strMsg As String Dim lRsp As Long Dim c As Range strMsg = "Add this item to the list?" Set ws = Worksheets("Lists") Set c = ActiveCell str = c.Validation.Formula1 str = Right(str, Len(str) - 1) On Error Resume Next Set rng = ws.Range(str) On Error GoTo 0 If rng Is Nothing Then Exit Sub Select Case KeyCode Case 9 c.Offset(0, 1).Activate If c.Value = "" Then Exit Sub If Application.WorksheetFunction _ .CountIf(rng, c.Value) Then Exit Sub Else lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?") If lRsp = vbYes Then i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1 ws.Cells(i, rng.Column).Value = c.Value rng.Sort Key1:=ws.Cells(1, rng.Column), _ Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End If End If Case 13 c.Offset(1, 0).Activate If c.Value = "" Then Exit Sub If Application.WorksheetFunction _ .CountIf(rng, c.Value) Then Exit Sub Else lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?") If lRsp = vbYes Then i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1 ws.Cells(i, rng.Column).Value = c.Value rng.Sort Key1:=ws.Cells(1, rng.Column), _ Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End If End If Case Else 'do nothing End Select End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim str As String Dim cboTemp As OLEObject Dim ws As Worksheet Dim wsList As Worksheet Dim rng As Range Dim i As Integer Dim strMsg As String Dim lRsp As Long Set ws = ActiveSheet Set wsList = Sheets("Lists") Set cboTemp = ws.OLEObjects("TempCombo") strMsg = "Add this item to the list?" If Target.Count > 1 Then GoTo exitHandler On Error Resume Next With cboTemp .ListFillRange = "" .LinkedCell = "" .Visible = False End With On Error GoTo errHandler If Target.Validation.Type = 3 Then Application.EnableEvents = False str = Target.Validation.Formula1 str = Right(str, Len(str) - 1) With cboTemp .Visible = True .Left = Target.Left .Top = Target.Top .Width = Target.Width + 15 .Height = Target.Height + 5 .ListFillRange = str .LinkedCell = Target.Address End With cboTemp.Activate End If exitHandler: Application.EnableEvents = True Application.ScreenUpdating = True Exit Sub errHandler: Resume exitHandler End Sub That code is Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Count = 1 Then If Not Target.Comment Is Nothing Then With Target.Comment.Shape .Left = Target.Left - .Width - 10 .Top = Target.Offset(1).Top End With End If End If End Sub So how do I run both code please I have tried and the combo box still has the larger font and long list to pick from. But the comment box still displays to the right I am not able to get both to work I have uploaded two sample files if you would like to have a look at them, they are only samples I have sent a xls and a xlsm files Hope this is ok I understand if you are reluctant to open them Hope you can help me Regards Edward |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Converting color codes in VBA | Ulodesk | Word VBA | 7 | 11-24-2014 04:15 AM |
Codes Popping Up In My Text? | Faedrie | Word | 1 | 11-08-2012 01:00 AM |
Outline Codes | eliz.bell | Word | 4 | 03-28-2012 07:27 PM |
Mail merge erases field codes | Medievalguy88 | Mail Merge | 1 | 08-11-2011 05:21 AM |
confusion with merge and field codes | BluRay | Mail Merge | 5 | 03-29-2011 01:06 AM |