Hi,

I'm trying to get my macro make a message come up and ask the customer
to choose company a or b. Then based on the result, i can open the
correct file.

I'm great at Excel, but this VB code has me stumped. Any help would be
appreciated. Other than that I'll have to make two separate macros.

Thanks,

Michele

One way:


Dim vResponse As Variant
Do
vResponse = LCase(Application.InputBox( _
Prompt:="Enter 'a' or 'b'", _
Default:="a", _
Title:="Choice", _
Type:=2))
If vResponse = False Then Exit Sub 'User Cancelled
Loop Until vResponse = "a" Or vResponse = "b"




In article .com,
wrote:

Hi,

I'm trying to get my macro make a message come up and ask the customer
to choose company a or b. Then based on the result, i can open the
correct file.

I'm great at Excel, but this VB code has me stumped. Any help would be
appreciated. Other than that I'll have to make two separate macros.

Thanks,

Michele

I've got this far, but the user can only choose one company. How can I
make both choices visible? And what does type 2 mean. I'm tried to
get a VB book, but the library is closed for the long weekend in
Canada.

Dim vResponse As Variant
Do
vResponse = LCase(Application.InputBox( _
Prompt:="Choose quote from Custom Safety or Severn
Tech", _
Default:="Custom Safety", _
Title:="Which company is quoting?", _
Type:=2))
If vResponse = False Then Exit Sub 'User Cancelled
Loop Until vResponse = "Custom Safety" Or vResponse = "Severn Tech"

If vResponse = True Then
If IsFileOpen("C:\Documents and Settings\John\My
Documents\quoteprogramfiles\csquoteform.xls") Then
MsgBox "Quote form is open. Save and close form
(csquoteform.xls) and try again."
Exit Sub
End If
End If

If vResponse = False Then
If IsFileOpen("C:\Documents and Settings\John\My
Documents\quoteprogramfiles\stquoteform.xls") Then
MsgBox "Quote form is open. Save and close form
(stquoteform.xls) and try again."
Exit Sub
End If
End If

If vResponse = True Then
Workbooks.Open filename:= _
"C:\Documents and Settings\John\My
documents\quoteprogramfiles\csquoteform.xls"
End If

If vResponse = False Then
Workbooks.Open filename:= _
"C:\Documents and Settings\John\My
documents\quoteprogramfiles\stquoteform.xls"
End If

Thanks again,

Michele


JE McGimpsey wrote:
One way:


Dim vResponse As Variant
Do
vResponse = LCase(Application.InputBox( _
Prompt:="Enter 'a' or 'b'", _
Default:="a", _
Title:="Choice", _
Type:=2))
If vResponse = False Then Exit Sub 'User Cancelled
Loop Until vResponse = "a" Or vResponse = "b"

In article .com,
wrote:

Hi,

I'm trying to get my macro make a message come up and ask the
customer
to choose company a or b. Then based on the result, i can open the
correct file.

I'm great at Excel, but this VB code has me stumped. Any help
would be
appreciated. Other than that I'll have to make two separate
macros.

Thanks,

Michele

Well, XL/VBA Help should be open...

The loop restricts the users choice, returned in vResponse, to either
Custom Safety or Severn Tech.

However, you test for True or False.

One possibility:


Do
'get vResponse
Loop Until...

If vResponse = "Custom Safety" Then
If IsFileOpen("C...\csquoteform.xls") Then
MsgBox...
Exit Sub
Else
Workbooks.Open filename:="C...\csquoteform.xls"
End If
Else
If IsFileOpen("C...\stquoteform.xls") Then
MsgBox...
Exit Sub
Else
Workbooks.Open filename:="C...\stquoteform.xls"
End If
End If


However this would be better:

Const sPATH = "C:\Documents...\quoteprogramfiles\"
Dim sFileName As String
Do
'get vResponse
Loop Until...

If vResponse = "Custom Safety" Then
sFileName = "csquoteform.xls"
Else
sFilename ="stquoteform.xls"
End If
If IsFileOpen(sPATH & sFileName) Then
MsgBox "Quote form is open. Save and close form (" & _
sFileName & ") and try again."
Exit Sub
Else
Workbooks.Open sPATH & sFileName
End If


In article . com,
wrote:

I've got this far, but the user can only choose one company. How can I
make both choices visible? And what does type 2 mean. I'm tried to
get a VB book, but the library is closed for the long weekend in
Canada.

Dim vResponse As Variant
Do
vResponse = LCase(Application.InputBox( _
Prompt:="Choose quote from Custom Safety or Severn
Tech", _
Default:="Custom Safety", _
Title:="Which company is quoting?", _
Type:=2))
If vResponse = False Then Exit Sub 'User Cancelled
Loop Until vResponse = "Custom Safety" Or vResponse = "Severn Tech"

If vResponse = True Then

Another way:

This is more complex but IMHO more elegant. It is intended to be used for
the situation where there is a variable number of companies to select from.
The companies must be listed on a worksheet ("Settings"). Typically, this
helper worksheet would be hidden. It creates on-the-fly a userform that that
has the same number of option buttons as companies in the list. The option
button captions are the same as the company names. It was written only
minutes ago and briefly tested so it likely could be improved. It can, of
course, be adapted to suit.

You need to:
1) Paste the code to a standard code module
2) Name a worksheet "Settings"
3) List in sheet "Settings" multiple company names in column A starting at
cell A1
4) Call the macro

The macro will return in a message box the user's selection. It is assumed
that you will do whatever with the result. The userform will self-delete.

Regards,
Greg

Const UFColor As Single = 10040115
Public UserSelection As String
Sub MakeUF()
Dim UF As Object
Dim Ctrl As Object
Dim rng As Range
Dim i As Integer
Dim Code As String

With Sheets("Settings")
Set rng = Intersect(.Range("A1").CurrentRegion, .Columns(1))
End With
Set UF = Application.VBE.ActiveVBProject.VBComponents.Add(3 )
UF.Properties("Width") = 170
UF.Properties("Caption") = "File selection"
With UF.Designer
Set Ctrl = .Controls.Add("Forms.Label.1")
With Ctrl
..Caption = "Select company..."
..ForeColor = UFColor
..Top = 5
..Left = 5
..Height = 15
..Width = 200
End With
For i = 1 To rng.Count
Set Ctrl = .Controls.Add("Forms.OptionButton.1")
With Ctrl
..Caption = rng(i, 1).Value
..ForeColor = UFColor
..Top = 20 + (i - 1) * 15
..Left = 5
..Height = 15
..Width = 150
..Value = (i = 1)
End With
Next
Set Ctrl = .Controls.Add("Forms.CommandButton.1")
With Ctrl
..Caption = "Apply"
..ForeColor = UFColor
..Top = 30 + (i - 1) * 15
..Left = 5
..Height = 20
..Width = 75
End With
Set Ctrl = .Controls.Add("Forms.CommandButton.1")
With Ctrl
..Caption = "Cancel"
..ForeColor = UFColor
..Top = 30 + (i - 1) * 15
..Left = 85
..Height = 20
..Width = 75
End With
End With

UF.Properties("Height") = Ctrl.Top + 45

Code = "Private Sub CommandButton1_Click()"
Code = Code & vbCrLf & "Dim i As Integer"
Code = Code & vbCrLf & "For i = 1 To Me.Controls.Count - 3"
Code = Code & vbCrLf & "If Me.Controls(i) = True Then"
Code = Code & vbCrLf & "UserSelection = Me.Controls(i).Caption"
Code = Code & vbCrLf & "Exit For"
Code = Code & vbCrLf & "End If"
Code = Code & vbCrLf & "Next"
Code = Code & vbCrLf & "Unload Me"
Code = Code & vbCrLf & "End Sub"
Code = Code & vbCrLf & "Private Sub CommandButton2_Click()"
Code = Code & vbCrLf & "Unload Me"
Code = Code & vbCrLf & "End Sub"
UF.CodeModule.InsertLines 2, Code

VBA.UserForms.Add(UF.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove UF
MsgBox UserSelection
End Sub

Hi Greg,

Pretty fancy. Way beyond my understanding. Impressed the h out of me.

Can I put this inside of my current macro? I tried to and it didn't
like Public, said invalid attribute in sub or function. I didn't want
the user to have to run two macros.

I put your code at the beginning of my macro, and then after it I added
this just before the End Sub to be able to pass the correct filename to
work with further down in the macro.

If UserSelection = "Custom Safety" = True Then
qfFileName = "CSQuoteform.xls"
Else
qfFileName = "STQuoteform.xls"
End If

Thanks a bunch,

Michele

Hi,

I ran it as a separate macro and I'm getting 'programmatic access to
Visual Basic Project is not trusted' on this line:
Set UF = Application.VBE.ActiveVBProject.VBComponents.Add(3 )

Thanks,

Michele

You need to allow it in Tools=Macro=Security

I believe it is in the trusted sources tab (a checkbox). (I don't have
xl2002/xl2003 handy at the moment).

--
Regards,
Tom Ogilvy

wrote in message
oups.com...
Hi,

I ran it as a separate macro and I'm getting 'programmatic access to
Visual Basic Project is not trusted' on this line:
Set UF = Application.VBE.ActiveVBProject.VBComponents.Add(3 )

Thanks,

Michele

It worked great for me when I tested it. Have you got it to work at all?

If you potentially have more than just two companies to select from then I
think this is the way to go. However, I've never seen that error message
before. I suspect it's to do with virus protection or you have a later
version of Excel than I do. (Perhaps it has to do with all that Digital
Certificate stuff that I've never paid attention to).

I don't think it will help but it's worth a try: From the main menu bar
select ToolsMacroSecurity"Trusted Sources" tab. Then ensure that the
"Trust all installed Add-ins and Templates" checkbox is selected.

Another suggestion is, from the VBE, select ToolsReferences and then select
the "MicroSoft Forms 2.0 Object library". I can't think of a logical reason
why this would be helpful granted. If you are not successful, I suggest
posting separately to see if someone else can help.

Sorry I couldn't be more helpful. Be advised that I'm just an amateur if
that isn't clear already.

Regards,
Greg

" wrote:

Hi,

I ran it as a separate macro and I'm getting 'programmatic access to
Visual Basic Project is not trusted' on this line:
Set UF = Application.VBE.ActiveVBProject.VBComponents.Add(3 )

Thanks,

Michele

Hi Greg,

It works now. It was that trusted sources thing. I had to check
'Trust access to Visual Basic Project'.

It works as a separate macro, but I'd still like to include it at the
top of mine. Since I don't know where to put the top two lines, I'm
confused as to what to do.

Here is my macro. I'd like to replace the 'Which company to do quote
for?' section with your much better code.

Sub Quote()
'
' Quote Macro
' Macro recorded 5/17/2005 by Michele J. Jones
'
' Keyboard Shortcut: Ctrl+q

' Which company to do quote for?
Const qfPath = "C:\Documents and Settings\John\My
Documents\quoteprogramfiles\"
Dim qfFileName As String
Dim vResponse As Variant
If MsgBox("Is quote for Custom Safety?", vbYesNo + vbQuestion,
"Quoting Company") = vbYes Then
qfFileName = "CSQuoteform.xls"
Else
qfFileName = "STQuoteform.xls"
End If

' Quit if quote is open and open if not
If IsFileOpen(qfPath & qfFileName) Then
MsgBox "Quote form is open. Save and close form " & qfFileName
& " and try again."
Exit Sub
Else
Workbooks.Open qfPath & qfFileName
End If

' Go to CUST column A and copy fields
Windows("cust.xls").Activate
Selection.End(xlToLeft).Select
Dim fn
Dim ln
Dim cm
Dim a1
Dim a2
Dim ci
Dim pr
Dim pc
Dim ph
Dim fx
fn = ActiveCell.Value
Selection.Offset(0, 1).Select
ln = ActiveCell.Value
Selection.Offset(0, 1).Select
cm = ActiveCell.Value
Selection.Offset(0, 1).Select
a1 = ActiveCell.Value
Selection.Offset(0, 1).Select
a2 = ActiveCell.Value
Selection.Offset(0, 1).Select
ci = ActiveCell.Value
Selection.Offset(0, 1).Select
pr = ActiveCell.Value
Selection.Offset(0, 1).Select
pc = ActiveCell.Value
Selection.Offset(0, 1).Select
ph = ActiveCell.Value
Selection.Offset(0, 1).Select
fx = ActiveCell.Value

' Position CUST on First Name
Selection.Offset(0, -9).Select

' Paste FirstName and LastName
Windows(qfFileName).Activate
Range("B11").Select
Selection = fn
Selection.Offset(0, 1).Select
Selection = ln

' Join First and Last Names
Selection.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],"" "",RC[-1])"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy

' Past Joined Name
Selection.Offset(0, -2).Select
ActiveSheet.Paste

' Remove OldJoined Name
Selection.Offset(0, 2).Select
Selection.ClearContents

' Remove Old LastName
Selection.Offset(0, -1).Select
Selection.ClearContents

' Paste Company, Address1, Address2, City, Prov & PC
Selection.Offset(-5, -2).Select
Selection = cm
Selection.Offset(1, 0).Select
Selection = a1
Selection.Offset(1, 0).Select
Selection = a2
Selection.Offset(1, 0).Select
Selection = ci
Selection.Offset(0, 1).Select
Selection = pr
Selection.Offset(0, 1).Select
Selection = pc

' Join City, Prov PC
Selection.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-3],"", "",RC[-2],""
"",RC[-1])"

' Make City, Prov PC into a value
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False

' Clear PC, Prov & City
Selection.Offset(0, -1).Select
Selection.ClearContents
Selection.Offset(0, -1).Select
Selection.ClearContents
Selection.Offset(0, -1).Select
Selection.ClearContents

' Merge City, Prov & PC Cells
Range("A9:C9").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

' Copy City, Prov PC
Range("D9").Select
Selection.Copy

' Paste City, Prov PC
Range("A9").Select
ActiveSheet.Paste

' Clear Old City, Prov PC
Range("D9").Select
Selection.ClearContents

' Paste Phone & Fax
Selection.Offset(3, -1).Select
Selection = ph
Selection.Offset(1, 0).Select
Selection = fx

' Position Quote on Company
Selection.Offset(-7, -1).Select

End Sub

If you're an amateur, I'm in real trouble, but alas, this is not my
only day job.

Thanks again,

Michele

Michele,

Sorry for the late response but I was away for the evening.

I suggest that:
1) In column A of Sheet("Settings") starting in cell A1 you put all the
company names. I assume you have done this already.
2) In column B put the corresponding file names that you want to open - i.e.
If "Company A" is in cell A1 then "CompanyA.doc" should be in B1 if this is
the file to open if the user selects "Company A" etc.
3) Paste the updated version of the MakeUF macro (appended below) to a
separate module and delete the one I gave you earlier.
4) At the start of your macro substitute the following:

Const qfPath As String = "C:\Documents and Settings\John\My
Documents\quoteprogramfiles\"

Sub Quote()
Dim qfFileName As String
Call MakeUF 'get UserSelection value
If UserSelection = 0 Then Exit Sub
qfFileName = CompanyNmRng(UserSelection, 2) 'Get corresponding file name
'Quit if quote is open and open if not
If IsFileOpen(qfPath & qfFileName) Then
MsgBox "Quote form is open. Save and close form " & qfFileName & " and
try again."
Exit Sub
Else
Workbooks.Open qfPath & qfFileName
End If
'The rest of your code follows...

*Note that the IsFileOpen function causes me an error. Since I did not see a
reference to a UDF with this name in either yours or J.E.'s posts I assume
this is supported in later versions. Also note that the rest of your code
could be simplified in that it's seldom necessary to select anything.
However, if it works then it works. Good luck.

Regards,
Greg

'Replace the earlier version of MakeUF with this. Paste to a separate module.
Const UFColor As Single = 10040115
Public UserSelection As Integer
Public CompanyNmRng As Range

Sub MakeUF()
Dim UF As Object
Dim Ctrl As Object
Dim i As Integer
Dim Code As String

With Sheets("Settings")
Set CompanyNmRng = Range(.Range("A1"), .Range("A1").End(xlDown))
End With
Set UF = Application.VBE.ActiveVBProject.VBComponents.Add(3 )
UF.Properties("Width") = 170
UF.Properties("Caption") = "File selection"
With UF.Designer
Set Ctrl = .Controls.Add("Forms.Label.1")
With Ctrl
..Caption = "Select company..."
..ForeColor = UFColor
..Top = 5
..Left = 5
..Height = 15
..Width = 200
End With
For i = 1 To CompanyNmRng.Count
Set Ctrl = .Controls.Add("Forms.OptionButton.1")
With Ctrl
..Caption = CompanyNmRng(i, 1).Value
..ForeColor = UFColor
..Top = 20 + (i - 1) * 15
..Left = 5
..Height = 15
..Width = 150
..Value = (i = 1)
End With
Next
Set Ctrl = .Controls.Add("Forms.CommandButton.1")
With Ctrl
..Caption = "Apply"
..ForeColor = UFColor
..Top = 30 + (i - 1) * 15
..Left = 5
..Height = 20
..Width = 75
End With
Set Ctrl = .Controls.Add("Forms.CommandButton.1")
With Ctrl
..Caption = "Cancel"
..ForeColor = UFColor
..Top = 30 + (i - 1) * 15
..Left = 85
..Height = 20
..Width = 75
End With
End With

UF.Properties("Height") = Ctrl.Top + 45

Code = "Private Sub CommandButton1_Click()" & _
vbCrLf & "Dim i As Integer" & _
vbCrLf & "For i = 1 To Me.Controls.Count - 3" & _
vbCrLf & "If Me.Controls(i) = True Then" & _
vbCrLf & "UserSelection = i" & _
vbCrLf & "Exit For" & _
vbCrLf & "End If" & _
vbCrLf & "Next" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub" & _
vbCrLf & "Private Sub CommandButton2_Click()" & _
vbCrLf & "UserSelection = 0" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub"
UF.CodeModule.InsertLines 2, Code

VBA.UserForms.Add(UF.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove UF
End Sub

Hi Greg,

No problem on the late response. I'm just glad you responded. I
really do appreciate the help. I've just started to work as an
independent and I seem to spend so much time learning (non-billable
time), but I assume I'll get the hang of it soon and start to work more
efficiently and make some money.

On the IsFileOpen, I got that from Microsoft. I think I got it from
he

http://support.microsoft.com/default...b;en-us;291295

Here is the code (and my notes to myself):

Add this IsFileOpen function to Excel by:
-Going into VB (Alt-F11)
-Insert
-Module
-Paste code below
-Exit VB

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.

' Check to see which error occurred.
Select Case errnum

' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False

' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True

' Another error occurred.
Case Else
Error errnum
End Select
End Function

I've got your code added and I'm getting a syntax error at the line '
For i = 1 To'. It appears in red in my code. I hope that's not a bad
thing because these lines are red, too:

..Caption = CompanyNmRng(

- Hide quoted text -
- Show quoted text -
i, 1).Value

and

()" & _
vbCrLf & "Dim i As Integer" & _
vbCrLf & "For i = 1 To Me.Controls.Count - 3" & _
vbCrLf & "If Me.Controls(i) = True Then" & _
vbCrLf & "UserSelection = i" & _
vbCrLf & "Exit For" & _
vbCrLf & "End If" & _
vbCrLf & "Next" & _
vbCrLf & "Unload Me" & _
vbCrLf & "End Sub" & _
vbCrLf & "Private Sub CommandButton2_Click()" & _
vbCrLf & "UserSelection = 0" & _
vbCrLf & "Unload Me" & _

vbCrLf & "End Sub"

yippes.

Also, do you know the reason that some of the code above in this email
is in blue. Am I supposed to understand something from this?

Thanks again Greg,

Michele

Hi Greg,

Got it! And it works great!

It copied funny and I ended up with some returns where they weren't
supposed to be.

There is a small error (runtime error '424' Object required) that
sometimes comes up at line 'VBA.UserForms.Add(UF.Name).Show' which is
the 2nd last line. It comes up when I've already run the macro and run
it again when the CSQuoteForm. xls is still open. But, then if I run
it a third time, it works okay and says the file is open and quits.

I can't thank you enough. There is still hope for humanity when kind
people like you exist.

Thanks,

Michele

Michele,

The technique I gave you creates on-the-fly a UF and then deletes it. It
doesn't have to be done this way. The UF can be made permanent and the option
buttons (OB's) can be added at run time. The command buttons can be
positioned to accomodate the number of OB's and the UF sized to suit.
Alternatively, the maximum number of OB's that would ever be required can be
added at design time and made invisible. The number required would then be
made visible at run time. I think this would get around the problem you
describe.

If you decide that you want to try this, I think you should start another
post as this one is rather old.

Best regards,
Greg

" wrote:

Hi Greg,

Got it! And it works great!

It copied funny and I ended up with some returns where they weren't
supposed to be.

There is a small error (runtime error '424' Object required) that
sometimes comes up at line 'VBA.UserForms.Add(UF.Name).Show' which is
the 2nd last line. It comes up when I've already run the macro and run
it again when the CSQuoteForm. xls is still open. But, then if I run
it a third time, it works okay and says the file is open and quits.

I can't thank you enough. There is still hope for humanity when kind
people like you exist.

Thanks,

Michele