I need to merge two VBA codes

[sam2149]

Hi I am running windows 7 and excel 2010 and I need to merge two codes the first code I have is to enable me to have combo boxes that I can click and select data from another sheet and place it in the cell, This combo box allows me to have a larger font and a longer list than the default excel picklist.

The code is s 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

But I also have a code that when i click on the cell with a comment box it makes the comment display to the left of the cell and one row down

The code is

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

If I try and add the second code to the first code it does run but the combo box reverts back to the default pick list IE small text and only 8 visible lines

Is it possible to merge to two codes please

Regards

 

[CharlesChuckieCharles]

where exactly did you try to merge the code into?

 

[sam2149]

Hi I already had the first code placed in the sheet with the data I just right clicked on the sheet tab and went to view code and just pasted the first code there.

Then with the second the second code 1 went to view code again on the sheet tab and pasted the second code into the start of the first code so they were both in the same place