Sub CreateAndRunQuery()
Dim cn As Object, rs As Object
Dim intColIndex As Integer
Dim DBData As String
Dim TargetRange As Range
Dim MyValues() As Variant
Dim i As Integer
Dim Ca As Range
10 DBData = "Z:\Users\rugge\AA SKYNET AA\Morgan Stanley.accdb"
20 On Error GoTo Whoa
30 Application.ScreenUpdating = False
40 Set TargetRange = Sheets("Sheet2").Range("a6")
50 Set Ca = Sheets("sheet2").Range("a1") <-------------------------------------------[b]Ca is the sheet range[/b]
60 Set cn = CreateObject("ADODB.Connection")
70 cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBData & ";"
80 Set rs = CreateObject("ADODB.Recordset")
90 rs.Open "Select * from Data where [Branch Number:] =" & Ca, cn
' Write the field names
100 For intColIndex = 0 To rs.Fields.Count - 1
110 TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
120 Next
' Write recordset
130 TargetRange.Offset(1, 0).CopyFromRecordset rs
LetsContinue:
140 Application.ScreenUpdating = True
150 On Error Resume Next
160 rs.Close
170 Set rs = Nothing
180 cn.Close
190 Set cn = Nothing
200 TargetRange.Clear
210 On Error GoTo 0
220 Exit Sub
Whoa:
230 MsgBox "Error Description :" & Err.Description & vbCrLf & _
"Error at line :" & Erl & vbCrLf & _
"Error Number :" & Err.Number
240 Resume LetsContinue
End Sub