Excel VBA循环到下一行并高亮显示工作表中的错误

我一直在使用下面的代码，这是我从一个网站上获得的，但是，用户总是忘记检查数据（ID）是否已经发送到Access数据库，是否有任何方法可以循环该过程并仍然导出数据，更改未处理项的字体颜色，并引入一个带有文本“not Imported”的新列?

---

感谢您的帮助，因为我不知道如何开始循环恢复下一步。我希望你们能帮助我更改或修改此代码。

阅读代码后，我想我终于明白了您想要做什么：

您希望在继续之前先检查行是否已导出

下面是更新后的脚本。

我更改了代码的几个部分的顺序，因为它们不一致或会导致错误

假设您的列是a到G，我添加了一个列H，在成功地将«导出»存储到数据库中后，H将存储该列

因此，这一点现在应该适用于您：

主子系统导出到Access 函数检查文件是否存在： 注意：现在有效ID仅为字符串类型

NB:请阅读«’###>»前面的任何评论，因为这些是您需要理解的主要更改或解释

更新： 以下是更新后的文件：

--->幸运的是，您向我发送了该文件，因为我看到DbPath指向错误的单元格，导致了丢失文件错误。现在一切都已修复并正常工作

---

祝你一切顺利

嗨@Mielkew，我不太明白你想做什么。你能给我解释一下吗，这样我可以帮你吗？事实上，在遵循你的脚本之后，我似乎明白你想要做什么，所以请测试代码并让我知道。当答案对您有效时，请接受它：）Hi@tsirinianarakotoninina我尝试了代码，但得到了一个错误“ByRef参数类型不匹配”，我将假设dbPath没有正确声明。我在数据库应用程序的filepath.GetOpenFilename中还有一个子文件，并将该值放在Sheet1.Range（“I3”）中。value=fName请立即尝试。我更新了脚本。很抱歉，我忘了声明DbPath、nRow和nCol。它现在应该可以工作了：）Hi@Tsirinianarakotoninina，我需要知道该ID是否已经存在于AccessDB中，如果确实存在，则应处理错误，如果错误指示在“H列”中未导出，以避免AccessDB中出现重复条目，然后继续下一行，但是，我的代码目前避免转到下一个值，如itHi@Mielkew，你可以在这里评论/回复我。让我来调查一下为什么会出现这种错误。请稍等我@TsiriniainaRakotonirina（），我真的很感谢你花时间看这个。非常感谢@Tsiriniaina arkotoninina，我明天回到办公室后会试试。保持安全，上帝保佑你。嗨@Tsiriniaina Rakotoninina我尝试了代码，工作得很好，但是当我将ID更改为字母数字时，我出错了？错误13类型不匹配？我还将AccessDB字段类型更改为“Short Text”，将函数IdExists nId更改为As StringHi@tsiriniina-Rakotonirina，我想我成功地关闭了，并将这个问题标记为已解决。再次感谢。

Sub Export_Data()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim x As Long, i As Long
Dim nextrow As Long

'add error handling
On Error GoTo errHandler:
'On Error Resume Next

'Variables for file path and last row of data
dbPath = ActiveSheet.Range("I3").Value
nextrow = Cells(Rows.Count, 1).End(xlUp).Row

'Initialise the collection class variable
Set cnn = New ADODB.Connection

'Check for data
If Sheet1.Range("A2").Value = "" Then
MsgBox " Add the data that you want to send to MS Access"
Exit Sub
End If

'Connection class is equipped with a —method— named Open
'—-4 aguments—- ConnectionString, UserID, Password, Options
'ConnectionString formula—-Key1=Value1;Key2=Value2;Key_n=Value_n;
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
'two primary providers used in ADO SQLOLEDB —-Microsoft.JET.OLEDB.4.0 —-Microsoft.ACE.OLEDB.12.0
'OLE stands for Object Linking and Embedding, Database

'ADO library is equipped with a class named Recordset
Set rst = New ADODB.Recordset 'assign memory to the recordset

'ConnectionString Open '—-5 aguments—-
'Source, ActiveConnection, CursorType, LockType, Options
rst.Open Source:="PhoneList", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable

'you now have the recordset object
'add the values to it
For x = 2 To nextrow
rst.AddNew
For i = 1 To 7
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x

'close the recordset
rst.Close
' Close the connection
cnn.Close
'clear memory
Set rst = Nothing
Set cnn = Nothing

'communicate with the user
MsgBox " The data has been successfully sent to the access database"

'Update the sheet
Application.ScreenUpdating = True

'show the next ID
'Sheet1.Range("J3").Value = Sheet1.Range("K3").Value + 1

'Clear the data
'Sheet1.Range("A2:G1000").ClearContents

On Error GoTo 0
Exit Sub
errHandler:

'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"

End Sub

Sub Export_Data_Updated()

Dim dbPath As String
Dim lastRow As Long
Dim exportedRowCnt As Long

'add error handling
On Error GoTo exitSub

'Check for data
'##> This should be first as it is useless to open cnx or find path/last row if this will exit the sub
    If Sheet1.Range("A2").Value = "" Then
    MsgBox " Add the data that you want to send to MS Access"
        Exit Sub
    End If

    '##> Only Continue when the above is fine

'##> Check if the path exits first
    'Variables for file path
    dbPath = ActiveSheet.Range("J3").Value  '##> This was wrong before pointing to I3

    If Not FileExists(dbPath) Then
        MsgBox "The Database file doesn't exist! Kindly correct first"
            Exit Sub
    End If

'##> Only then that you can proceed
    'find las last row of data
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'##> Change the Error handler now
    Dim cnx As ADODB.Connection 'dim the ADO collection class
    Dim rst As ADODB.Recordset 'dim the ADO recordset class

    On Error GoTo errHandler

    'Initialise the collection class variable
    Set cnx = New ADODB.Connection

    'Connection class is equipped with a —method— named Open
    '—-4 aguments—- ConnectionString, UserID, Password, Options
    'ConnectionString formula—-Key1=Value1;Key2=Value2;Key_n=Value_n;
    cnx.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
    'two primary providers used in ADO SQLOLEDB —-Microsoft.JET.OLEDB.4.0 —-Microsoft.ACE.OLEDB.12.0
    'OLE stands for Object Linking and Embedding, Database

    'ADO library is equipped with a class named Recordset
    Set rst = New ADODB.Recordset 'assign memory to the recordset

    'ConnectionString Open '—-5 aguments—-
    'Source, ActiveConnection, CursorType, LockType, Options
    rst.Open Source:="PhoneList", ActiveConnection:=cnx, _
    CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
    Options:=adCmdTable

'##> Continue reading Database now
    'you now have the recordset object
    'add the values to it

    'Wait Cursor
    Application.Cursor = xlWait

    'Pause Screen Update
    Application.ScreenUpdating = False

    '##> Set exportedRowCnt to 0 first
    exportedRowCnt = 0

        '##> Let's suppose Data is on Column A to G.
        '    --> So let's put the "Exported" on Column H
    For nRow = 2 To lastRow
        '##> Check if the Row has already been imported?
        'If it it isn't then continue
        If IdExists(cnx, Range("A" & nRow).Value) Then
            'Item already exported, so update the Status
            Range("H" & nRow).Value2 = "Exported"
        Else
            rst.AddNew  'Add New RecordSet
                'Itirating Columns
                For nCol = 1 To 7
                    rst.Fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value 'Using the Excel Sheet Column Heading
                Next nCol

            rst.Update  'Update RecordSet

            '##>Update the Status on Column H when the record is successfully updated
            Range("H" & nRow).Value2 = "Exported"

            'Increment exportedRowCnt
            exportedRowCnt = exportedRowCnt + 1
        End If
    Next nRow

    'close the recordset
    rst.Close

    ' Close the connection
    cnx.Close
    'clear memory
    Set rst = Nothing
    Set cnx = Nothing

    If exportedRowCnt > 0 Then
        'communicate with the user
        MsgBox exportedRowCnt & " row(s) successfully sent to the access database"
    End If

    'Update the sheet
    Application.ScreenUpdating = True
exitSub:
    'Restore Default Cursor
    Application.Cursor = xlDefault

    'Update the sheet
    Application.ScreenUpdating = True
        Exit Sub

errHandler:
    'clear memory
    Set rst = Nothing
    Set cnx = Nothing
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"

    Resume exitSub
End Sub

Function IdExists(cnx As ADODB.Connection, sId As String) As Boolean

'##> Set IdExists as False and change to true if the ID exists already
    IdExists = False

'##> Change the Error handler now
    Dim rst As ADODB.Recordset 'dim the ADO recordset class
    Dim cmd As ADODB.Command   'dim the ADO command class

    On Error GoTo errHandler

    'Sql For search
    Dim sSql As String
    sSql = "SELECT Count(PhoneList.ID) AS IDCnt FROM PhoneList WHERE (PhoneList.ID='" & sId & "')"

    '##> Execute command and collect it into a Recordset
    Set cmd = New ADODB.Command
    cmd.ActiveConnection = cnx
    cmd.CommandText = sSql

    'ADO library is equipped with a class named Recordset
    Set rst = cmd.Execute 'New ADODB.Recordset 'assign memory to the recordset

    'Read First RST
    rst.MoveFirst

'##> If rst returns a value then ID already exists
    If rst.Fields(0) > 0 Then
        IdExists = True
    End If

    'close the recordset
    rst.Close

    'clear memory
    Set rst = Nothing
exitFunction:
        Exit Function

errHandler:
    'clear memory
    Set rst = Nothing
        MsgBox "Error " & Err.Number & " :" & Err.Description
End Function