Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-26-2014, 05:28 AM
sam2149 sam2149 is offline Is it possible to merge the two VBA codes into just one Windows 7 64bit Is it possible to merge the two VBA codes into just one Office 2010 32bit
Novice
Is it possible to merge the two VBA codes into just one
 
Join Date: Feb 2014
Posts: 13
sam2149 is on a distinguished road
Default

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
But I have another code that make any comment box when I click on it to display on the left of the cell and one row down

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
The problem I have is if I add the second code to the first one it works ok the comment box displays to the left and one row down and the combo boxes still work, but the larger font and the longer pick list are gone its reverted back to the excel pick list with small text and only 8 lines visible

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
Attached Files
File Type: xlsm Sample Data1.xlsm (28.7 KB, 12 views)
File Type: xls Sample Data2.xls (58.5 KB, 8 views)
Reply With Quote
Reply

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
Is it possible to merge the two VBA codes into just one Codes Popping Up In My Text? Faedrie Word 1 11-08-2012 01:00 AM
Is it possible to merge the two VBA codes into just one Outline Codes eliz.bell Word 4 03-28-2012 07:27 PM
Is it possible to merge the two VBA codes into just one Mail merge erases field codes Medievalguy88 Mail Merge 1 08-11-2011 05:21 AM
Is it possible to merge the two VBA codes into just one confusion with merge and field codes BluRay Mail Merge 5 03-29-2011 01:06 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:13 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft