How do i run two VBA codes on one worksheet

sam2149

New member
Joined
Feb 26, 2014
Messages
5
Reaction score
0
Points
0
Hi I have one code placed in my worksheet that's give me the facility to have a combo box that when clicked on open a pick list on another sheet and enter it into the cell, it also allows me to see a larger font and a longer list to pick from the first code is as follows

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


The second code is to make a comment box when clicked on display to the left of the cell

----------------------------------------------------------------------------------------------------------------------------------------------------------------------

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

I can get both to work one at a time but no both together

Is it possible to have both codes on one work sheet please
 
attach please a sample file for testing
 
Hi thank you or the reply to my question I have encoded two sample files. sample data1 is a macro enabled excel 2010 file and sample Data2 is a excel 97-2007 excel file

As you will be able to see if you click on ether of the combo boxes I get a pick list that has larger font and the list is longer then the normal excel pick list


Bu my problem is I would like to add this second code below

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

This code makes any comment box when clicked on it display to the left of the cell and one row down

But when I add this code the combo boxes revert back to the normal small font an only 8 lines showing in the pick list

Hope you can help me

Regards Edward
 

Attachments

  • Sample Data1.xlsm
    28.7 KB · Views: 11
  • Sample Data2.xls
    58.5 KB · Views: 13
Last edited:
Ps I must have done something wrong in the upload of the sample files as they will not open any idea what I have done wrong
 
I can read the 2 attached file, but I'm not sure your approach is correct, can you explain me your goal ?
 
Hi my goal is to have the combo boxes show me a larger font and a longer list to pick from, as you will be able to see. the default excel pick list is a very small font and it only shows 8 lines and then you have to scroll down to see the rest. with the code that's in the sample fie I can get the result I need.

But the worksheet I need to use there are quite a few columns and I have one column right on the far right of my screen with some cells with comments in them, and when I hover the mouse over them they open but display to the right of the cell and go of the screen.

The second code alters this and makes the comment box once clicked on display to the left and one row down and this is what I am trying to do.

I have merged both codes and I get the comment box displaying as I want but the combo box reverts back to the excel default list with only 8 lines and a very small text

Regards
 
I'm sorry but I can not understand, you are speaking about combobox and I can't see any combo
 
Ok am sorry if I did not explain better if you look at the sample file I sent. I am using excel 2010 if you go to the developer tab on the ribbon, and then click on design mode one of the cells B2 to B8 or C2 to C8 will come alive with a box slightly larger than the normal cell, it will have a small arrow pointing down, if you then click on the box that has just been highlighted, then look in the name box just above column A you will see its called TempCombo and then across to the right just above column B or C you will see =EMBED("Forms.ComboBox.1","").

As far as I know this is a combo box but I might be wrong as I have been wrong before

I might be looking at this the wrong way what I need happen is the sample file to work like it is in the file I sent IE with a larger font and a longer list to pick from and not the default excel pick list with the small font and only 8 lines to choose from without scrolling down

But I also want any comment box when clicked on display to the left and one row down if you can think of better way to achieve this please let me know

Regards
 
Last edited:
Back
Top