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
|