macro copy multiple recordsets 2 excel

Dim intcount
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
con.Open "connection string"
rs.Open "sp name", con, adOpenKeyset, adLockOptimistic
intcount = 1
Do Until rs.EOF
Do While Not rs.EOF
For aloop = 0 To rs.Fields.Count - 1
Application.Workbooks("oas.xls").Worksheets("Sheet" & intcount).Range("A1").Offset(0, aloop).Value = rs.Fields(aloop).Name
Next
Application.Workbooks("oas.xls").Worksheets("Sheet" & intcount).Range("A2").CopyFromRecordset rs
intcount = intcount + 1
Loop
Set rs = rs.NextRecordset
If rs.State = 0 Then Exit Sub
Loop
Set rs = Nothing
Set con = Nothing

find a stored procedure containing text

SELECT ROUTINE_NAME, ROUTINE_DEFINITION
FROM INFORMATION_SCHEMA.ROUTINES
WHERE ROUTINE_DEFINITION LIKE '%foobar%'
AND ROUTINE_TYPE='PROCEDURE'