Looking for help with a macro/vba for find/copy/paste

Sub SQL()
' Requires "Microsoft ActiveX Data Objects 6.1 Library"
' Add using Tools, Reference

'Workbook MUST be saved at least once for this to work

Dim sqlstr As String
Dim rs As New ADODB.Recordset
Dim conn As ADODB.Connection

'######################################################################
'## Turn off all Application updating stuff
'######################################################################
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set conn = New ADODB.Connection
                
MyName = ThisWorkbook.Name

myPath = ThisWorkbook.Path
MyFullname = ThisWorkbook.FullName

strConn = "DSN=Excel Files;DBQ=" & MyFullname & ";DefaultDir=" & myPath & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
 
conn.Open strConn
conn.CommandTimeout = 0

' Find a unique list of non blank parts WITHOUT the suffix
' and the highest value of the last character for that part.
' where the last character is between A and Z

sqlstr = ""
sqlstr = sqlstr + "select distinct left(part,len(part)-4) as part2, "
sqlstr = sqlstr + " MAX(right(part,1)) as maxright"
sqlstr = sqlstr + " FROM [" + ActiveSheet.Name + "$]"
sqlstr = sqlstr + " WHERE part IS not NULL "
sqlstr = sqlstr + " and ucase(part) like '%[A-Z]'"
sqlstr = sqlstr + " group by left(part,len(part)-4)"

'Run It!
rs.Open sqlstr, conn

' format range as Text
ActiveSheet.Range("D2:E" & Rows.Count).NumberFormat = "@"
' Clear the area
ActiveSheet.Range("D2:E" & Rows.Count).ClearContents
' put the dataset retrieved into the range
ActiveSheet.Range("D2").CopyFromRecordset rs

'close the open connection and recordset
rs.Close
conn.Close
Set conn = Nothing

'######################################################################
'## Turn on all Application updating stuff
'######################################################################
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub