Macro to choose data and export in another workbook

[jerrycollins6]

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 ne
workbook.

Thank you for your help

 

[Ben McClave]

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

 

[jerrycollins6]

Hi Jerry,

It sounds like you need a UserForm, since you're looking for the user t
"choose" from a list. If so, step one would be to create a UserFor
with a ComboBox (ComboBox1) and a Command Button (CommandButton1).
After adding these items (and making the form look nice in general), ad
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 th
UserForm and display a unique list of values from the range you specif
(in the example, A1:A10). Once the UserForm unloads, the macro check
for a null string and cancels if one is found. Otherwise, a ne
workbook is opened and a message box displays the value selected by th
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 i
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 : suplie
1 or supplier 2 or Customer.

and a button export.

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


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

Cheer

 

[Ben McClave]

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

 

[jerrycollins6]

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 ?

 

[Ben McClave]

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

 

[jerrycollins6]

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 t
"Microsoft ActiveX Data Objects 6.0 Library" (or the highest versio
number you have, if there is no 6.0 option).

Once the reference has been set, you can click Debug > Compil
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 erro

 

[Ben McClave]

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.

 

[jerrycollins6]

Jerry,

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

cn.Open strCon

If so, try saving the workbook and running it again. If that is not th
issue, you may also want to double-check any Range references in th
code. For example, the sSQL parameter assumes that the relevant colum
header on the "ICD" sheet is in cell A1. If this is incorrect, the SQ
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,

jerr

 

[Ben McClave]

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

 

[jerrycollins6]

Jerry,

Try this instead. There are two procedures below. The key component i
a Function from Ozgrid.com that will return a range with all cell
matching a find value. The first procedure calls that function an
(assuming that the range returned is not Nothing), will copy the entir
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 eac
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

jerr

 

[Ben McClave]

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

 

[jerrycollins6]

Hi Jerry,

Unless I set up my test workbook differently than yours, the code seem
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 nea
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 shee
called "ICD", and that the range of values to search ("rFind") is in th
range A1:A100 of the "ICD" sheet. I further assumed that the text we'r
searching for ("sFind") can be found in cell A1 of the "HOME" tab. I
one of these variables is off, the code may not react as expected.

If the variables have been set correctly, please consider posting
sample version of your workbook so that I can take a look at how th
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 th
words from the list.
but bellow the combo box, still in A1, on the right, it gives a numbe
according to the word. for example if I choose customer, it says 1 the
2 or 3 for the others.

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

 

[Ben McClave]

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

 

[jerrycollins6]

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

 

[Ben McClave]

Jerry,

See if this returns the expecting search value:

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

Ben

 

[isabelle]

hi,

is that this "SelText" comes from delphi code ?

isabelle


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

 

[Ben McClave]

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

 

[jerrycollins6]

Isabelle,

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

As an alternative, I wrote a function to check a shape object's type an
return the selected text. In the case that the object is not a DropDow
or ActiveX control, it will check the value in the linked cell (in thi
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("Comb
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

 

[Ben McClave]

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