row = 2
email = sh.Range("A" & row)
...
For r = row to LastRow
...
objMessage.To = email
...
Next
You set email
to the value of the cell "A2"
and never change it. If you want to send a mail to multiple recipients, you should make that
objMessage.To = sh.Range("A" & r).Value
or (better) build a recipient list (assuming that your used range starts with headers in the first table row):
ReDim recipients(LastRow - row)
For r = row To LastRow
recipients(r - row) = sh.Range("A" & r).Value
Next
objMessage.To = Join(recipients, ";")
and send the message just once. The MTA will handle the rest.
Side note: as Vishnu Prasad Kallummel pointed out in the comments your code doesn't close the Excel instance it started. Unlike other objects created in VBScript, Office applications won't automatically terminate with the script, so you have to handle it yourself:
...
wb.Close
app.Quit