Export Excel sheet directly to MSSQL using script

Sub WriteSQLData()Dim rst As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim cnnStr As String
Dim rCnt As Long
Dim cCnt As Integer
Dim pKeyFail As Long




On Error GoTo Err_Handler




    'cnnStr = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=sqlExpress;Initial Catalog=Northwind"
    'fill in the gaps with your server information
    cnnStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=127.0.0.1;Initial Catalog=headcounttest"
    
    Set cnn = New ADODB.Connection
    Set rst = New ADODB.Recordset
    cnn.ConnectionString = cnnStr
    cnn.Open
'   Add correct table Ref here
    rst.Open "dbo.headcountstest", cnn, adOpenDynamic, adLockOptimistic
    Sheets("Sheet1").Activate   'change for sheet containing your data
    
    'I'm assuming that data starts at A1 and has fieldnames in row 1
    'and that the columns are in the correct order...blah blah
    
    For rCnt = 2 To Range("A1").CurrentRegion.Rows.Count
            rst.AddNew
                For cCnt = 1 To Range("A1").CurrentRegion.Columns.Count
                    rst.Fields(cCnt - 1) = Cells(rCnt, cCnt).Value
                Next cCnt
            rst.Update
    Next rCnt
    
    If pKeyFail > 0 Then
        MsgBox "A total of " & pKeyFail & " records were not exported due to Primary Key Problems", , "SQL Export"
    Else
        MsgBox "Export Finished", , "SQL Export"
    End If
    
    
    Exit Sub
Err_Handler:
    
    Select Case Err.Number
        Case -2147217873
            pKeyFail = pKeyFail + 1
            Debug.Print Cells(rCnt, 1).Value & "..." & Cells(rCnt, 2).Value
            rst.CancelUpdate
            Resume Next
        Case Else
            MsgBox "an unexpected error has occured" & vbCr & "Number: " & Err.Number & "Desc: " & Err.Description
    End Select
    
    
End Sub