Hi guys,

I would like, to have some help for the beginning of my code.

I have a big spreadsheet with lot of data
I have a column which is filled with different words: supplier 1, Supplier 2, Customer.

I would like to write a code saying :

Choose supplier 1,or Supplier 2, or Customer.
then open a new workbook, and export data regarding the chosen word.

I would like help only for choosing the word and then openning a new workbook.

Thank you for your help.

Hi Jerry,

It sounds like you need a UserForm, since you're looking for the user to "choose" from a list. If so, step one would be to create a UserForm with a ComboBox (ComboBox1) and a Command Button (CommandButton1). After adding these items (and making the form look nice in general), add this code to the UserForm's module:

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

Private Sub CommandButton1_Click()
sChosenWord = ComboBox1.Text
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim v As Variant

With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each v In Range("A1:A10") 'Change to suit
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
.Add v, Nothing
Me.ComboBox1.AddItem v
End If
Next v
End With

End Sub

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

Next, in Module1, add this code:

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

Public sChosenWord As String

Sub OpenWorkbook()
Dim wbNew As Workbook

sChosenWord = vbNullString

UserForm1.Show

If sChosenWord = "" Then Exit Sub 'User canceled, exit

Set wbNew = Workbooks.Add

MsgBox "User chose: " & sChosenWord
End Sub


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


To use this, just run the OpenWorkbook macro. It will call up the UserForm and display a unique list of values from the range you specify (in the example, A1:A10). Once the UserForm unloads, the macro checks for a null string and cancels if one is found. Otherwise, a new workbook is opened and a message box displays the value selected by the user.

Hope this helps get you started,

Ben

Cheers for your answer. You helped me a lot.

Anyway, I have more details of what I need. I ve done something but it is not very elegant.

Still is my big workbook.

I have two spreadsheets: one is "HOME" the other one is "ICD"

in the spreadsheet HOME I need a combo box where I can choose : suplier 1 or supplier 2 or Customer.

and a button export.

the code will have to export in the spreadsheet "ICD" the line where it is written the choosen word.


Could you give me an example of code saying this so I can modify mine ?

Cheers

Sorry I wanted to say :

the code will have to open a new workbook and export in it the line (in the sheet "ICD") where it is written the choosen word.

Jerry,

The macros below should do the trick. All you'll need to do is set up a drop-down list in any cell on your "HOME" sheet (using Data Validation). In a module of your workbook, add the code below and be sure to point "sParameter" to the correct cell in your workbook (this macro assumes that the drop-down list is in cell A1). Then add a button to the sheet and assign it the macro "CopyToNew".

Hope this helps,

Ben

CODE:
------------------------------
Option Explicit
Public sParameter As String
Public wbNew As Workbook

Sub CopyToNew()
'Set sParameter range to the range containing your drop-down list
sParameter = ThisWorkbook.Sheets("HOME").Range("A1").Value

Set wbNew = Workbooks.Add 'Adds a new workbook

'Copy header row to new sheet(assumes headers in row 1 of "ICD" sheet)
ThisWorkbook.Sheets("ICD").Rows(1).Copy wbNew.Sheets(1).Range("A1")

'Call macro to move the matching row(s)
MoveSheet wbNew.Sheets(1).Range("A2")

End Sub

Sub MoveSheet(rCopy As Range)
'Requires reference to ActiveX Data Objects Libraray
Dim sSQL As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strFile As String
Dim strCon As String

'Create recordset using SQL string
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

sSQL = "SELECT * FROM [ICD$] WHERE [" & ThisWorkbook.Sheets("ICD").Range("A1").Value & "] = " & _
Chr(39) & sParameter & Chr(39) & ";"

rs.Open sSQL, cn

'Copy Records to the new workbook
rCopy.CopyFromRecordset rs

'Close connection and exit
cn.Close
Set rCopy = Nothing
Set wbNew = Nothing

End Sub

hi Ben thank you for your help.
however it says that it doesn t recognize "Dim cn As ADODB.Connection"

and it highlights "Sub MoveSheet(rCopy As Range)" in yellow
what is the problem with that ?

ok now I have giben the microsoft active X object reference 2.8 I don t know why..

but now it highlights rs.Open sSQL, cn wrong language.

do you know why ? and how to choose de reference

Jerry,

It sounds like you don't have the Microsoft ActiveX reference set. Within the VBA Editor go to TOOLS REFERENCES and check the box next to "Microsoft ActiveX Data Objects 6.0 Library" (or the highest version number you have, if there is no 6.0 option).

Once the reference has been set, you can click Debug Compile VBAProject to see if it still gives you an error.

Ben

hi , i found it and put the active X 6 but still gives me an error

Jerry,

Is it the same error, or a different one? If you are trying it in a workbook that has not been saved, then you may get an error on the line:

cn.Open strCon

If so, try saving the workbook and running it again. If that is not the issue, you may also want to double-check any Range references in the code. For example, the sSQL parameter assumes that the relevant column header on the "ICD" sheet is in cell A1. If this is incorrect, the SQL query will break.

Hi Ben !

the workook is saved. the error on cn.Open strCon says:

Incompatible type of data in the expression of the criteria .

I have cheked the references. but still not working.
do you know if there is another way to do it without using SSQL ?

cheers,

jerry

Jerry,

Try this instead. There are two procedures below. The key component is a Function from Ozgrid.com that will return a range with all cells matching a find value. The first procedure calls that function and (assuming that the range returned is not Nothing), will copy the entire row for each found item and paste them to a new workbook.

Let me know if this one gives you any trouble.

Ben

Sub MoveToNewWB()
Dim ws As Worksheet 'ICD Sheet
Dim wbNew As Workbook 'New WB
Dim wsDest As Worksheet 'Destination WS
Dim rFind As Range 'Range to search for names
Dim rFound As Range 'Range of found names
Dim sFind As String 'Name to find

'Assign variables
Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("A1:A100")
sFind = ThisWorkbook.Sheets("HOME").Range("A1").Value

'Find names
On Error Resume Next
Set rFound = Find_Range(sFind, rFind).EntireRow

'Copy name rows over to new book
If Not rFound Is Nothing Then
Workbooks.Add
Set wbNew = ActiveWorkbook
Set wsDest = wbNew.Sheets(1)
ws.Range("1:1").Copy wsDest.Range("1:1") 'Copy headers
rFound.Copy
wsDest.Range("A2").PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
Else
MsgBox sFind & " not found."
End If

End Sub
Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range

'http://www.ozgrid.com/forum/showthread.php?t=27240

Dim c As Range
Dim firstAddress As String
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlWhole 'xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With

End Function

Hi Ben it works a lot better !!
thank you

However,there is one last thing to solve: it is supposed to copy each row regarding the choosen word.
Actually it only copy the first one.
there are several rows in the ICD sheet for the choosen word.

thank you very much for your help

cheers

jerry

Hi Jerry,

Unless I set up my test workbook differently than yours, the code seems to work fine. I think that the problem probably lies in the variables. There are only three variables to feed the code. They are found near the top:

'Assign variables
Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("A1:A100")
sFind = ThisWorkbook.Sheets("HOME").Range("A1").Value

When the code runs, it will search:

(1) Within the "ws" sheet
(2) In the "rFind" range
(3) for the text value assigned to "sFind"

I assumed that the worksheet containing data to copy ("ws") is the sheet called "ICD", and that the range of values to search ("rFind") is in the range A1:A100 of the "ICD" sheet. I further assumed that the text we're searching for ("sFind") can be found in cell A1 of the "HOME" tab. If one of these variables is off, the code may not react as expected.

If the variables have been set correctly, please consider posting a sample version of your workbook so that I can take a look at how the code interacts with your data set.

Ben

ok I've found what the problem is.

in the sheet home, in cell A1 ,I have a combo box where I can choose the words from the list.
but bellow the combo box, still in A1, on the right, it gives a number according to the word. for example if I choose customer, it says 1 then 2 or 3 for the others.

the code, doesn't look for the names it looks for the number. that's why it doesn t work properly.

I see.

If your combo box is a "DropDown" type, then you could add a new variable to the code, and use that to populate the "sFind" variable. Here are the new lines to include:

Dim dd As DropDown 'DropDown box
Set dd = ThisWorkbook.Sheets("HOME").Shapes("Drop Down 1").OLEFormat.Object
sFind = dd.List(dd.ListIndex)

To determine if your combobox is a DropDown, enter this line in the Immediate Window to see if it returns "8":

Print ThisWorkbook.Sheets("HOME").Shapes("Drop Down 1").Type

it says it doesn t find this element. Apologies but it is not a drop down it is the combo box not with active X

Jerry,

See if this returns the expecting search value:

sFind = ThisWorkbook.Sheets("HOME").ComboBox1.SelText

Ben

hi,

is that this "SelText" comes from delphi code ?

isabelle


Le 2012-12-30 15:28, Ben McClave a écrit :
Jerry,

See if this returns the expecting search value:

sFind = ThisWorkbook.Sheets("HOME").ComboBox1.SelText

Ben

Isabelle,

SelText is a method for an ActiveX object (not Delphi code to my knowledge).. I know that Jerry mentioned the combobox is not an ActiveX object, but as far as I can tell the object should be either a "DropDown" type (Form control) or an ActiveX type. Since "DropDown" did not work, I thought it would be worth checking if the ActiveX method would work.

As an alternative, I wrote a function to check a shape object's type and return the selected text. In the case that the object is not a DropDown or ActiveX control, it will check the value in the linked cell (in this case "A1") to find the correct value using Select Case.

Ben

Function GetText(ws As Worksheet, sShapeName As String) As String

' ws = Worksheet containing ComboBox
' sShapeName = Name of ComboBox
' Example:
' GetText(ThisWorkbook.Sheets("HOME"), "ComboBox1")

Dim sShape As Shape
Dim dd As DropDown
Dim sText As String
Err.Clear

'Set range on next line to the ComboBox's Linked Cell
sText = ws.Range("A1").Value

On Error Resume Next

Set sShape = ws.Shapes(sShapeName)
If sShape Is Nothing Then GoTo NoShape

Select Case sShape.Type
Case 8 'Drop Down
Set dd = sShape.OLEFormat.Object
If Err.Number 0 Then GoTo NoShape
GetText = dd.List(dd.ListIndex)
Exit Function
Case 12 'ActiveX
GetText = ws.OLEObjects(sShapeName).Object.SelText
If Err.Number = 0 Then Exit Function
End Select

NoShape:
If Not IsNumeric(sText) Then
GetText = sText
Else
Select Case sText
Case 1
GetText = "Customer 1"
Case 2
GetText = "Customer 2"
Case 3
GetText = "Supplier"
Case Else
GetText = vbNullString
End Select
End If

End Function

My excel is in french , and it is said 'combined zone 89'

I have add this to the code:


Dim strVar As String

With Worksheets("Home")
strVar = .DropDowns("Zone combinée 89").List _
(.DropDowns("Zone combinée 89").ListIndex)
End With



so it goes like this:


Sub MoveToNewWB()
Dim ws As Worksheet 'ICD Sheet
Dim wbNew As Workbook 'New WB
Dim wsDest As Worksheet 'Destination WS
Dim rFind As Range 'Range to search for names
Dim rFound As Range 'Range of found names
Dim sFind As String 'Name to find
'Dim dd As DropDown 'DropDown box
'Set dd = ThisWorkbook.Sheets("Home").Shapes("Combo Box1").OLEFormat.Object
'sFind = dd.List(dd.ListIndex)


Dim strVar As String

With Worksheets("Home")
strVar = .DropDowns("Zone combinée 89").List _
(.DropDowns("Zone combinée 89").ListIndex)
End With

MsgBox strVar

sFind = strVar

'Assign variables
Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("A1:A100")
sFind = ThisWorkbook.Sheets("Home").Range("A1").Value



the problem is it still look for the number and not for the name.
I don t understand why .

ok forget the previous mail. I have made some modification as you can see below. and now it works thanks for everything mate.


Happy new year by the way! ;)
Sub MoveToNewWB()
Dim ws As Worksheet 'ICD Sheet
Dim wbNew As Workbook 'New WB
Dim wsDest As Worksheet 'Destination WS
Dim rFind As Range 'Range to search for names
Dim rFound As Range 'Range of found names
Dim sFind As String 'Name to find
'Dim dd As DropDown 'DropDown box
'Set dd = ThisWorkbook.Sheets("Home").Shapes("Combo Box1").OLEFormat.Object
'sFind = dd.List(dd.ListIndex)


Dim strVar As String

With Worksheets("Home")
strVar = .DropDowns("Zone combinée 89").List _
(.DropDowns("Zone combinée 89").ListIndex)
End With

MsgBox strVar

sFind = strVar

'Assign variables

Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("D2:D100")
sFind = strVar



'Find names
On Error Resume Next
Set rFound = Find_Range(sFind, rFind).EntireRow

'Copy name rows over to new book
If Not rFound Is Nothing Then
Workbooks.Add
Set wbNew = ActiveWorkbook
Set wsDest = wbNew.Sheets(1)
ws.Range("1:1").Copy wsDest.Range("1:1") 'Copy headers
rFound.Copy
wsDest.Range("A2").PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
Else
MsgBox sFind & " not found."
End If

End Sub



Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range
Dim c As Range
Dim firstAddress As String
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlWhole 'xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With

End Function

Jerry,

You have "sFind" in your code twice. The second time it is assigning the value in cell A1 (which is just the number, not the text). Does your message box display the correct name? If so, simply delete this line from your code:

sFind = ThisWorkbook.Sheets("Home").Range("A1").Value

Ben

Hi Ben ,

I have made some new modifications in the code.
So basically, I choose "Supplier/customer" then the code will export row one in ICD , and find in it the rows related to the word.

However I ve been asked to be able to choose the column.

Say: row one contains the name of the informations.

So, after choosing the word and before clicking on export, I need to be able to choose the column (information) to export. A kind of form where user can select it

Let me know if you understand what I am saying.

Best Regards