Macro to choose data and export in another workbook
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. |
Macro to choose data and export in another workbook
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 |
Quote:
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 |
Quote:
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. |
Macro to choose data and export in another workbook
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 |
Quote:
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 ? |
Quote:
but now it highlights rs.Open sSQL, cn wrong language. do you know why ? and how to choose de reference |
Macro to choose data and export in another workbook
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 |
Quote:
|
Macro to choose data and export in another workbook
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. |
Quote:
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 |
Macro to choose data and export in another workbook
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 |
Quote:
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 |
Macro to choose data and export in another workbook
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 |
Quote:
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. |
Macro to choose data and export in another workbook
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 |
Quote:
|
Macro to choose data and export in another workbook
Jerry,
See if this returns the expecting search value: sFind = ThisWorkbook.Sheets("HOME").ComboBox1.SelText Ben |
Macro to choose data and export in another workbook
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 |
Macro to choose data and export in another workbook
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 |
Quote:
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 . |
Quote:
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 |
Macro to choose data and export in another workbook
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 |
Quote:
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 |
All times are GMT +1. The time now is 11:37 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com