0

我是Vba的新手，希望有人能解决我的问题。我正在尝试更新电子表格中存在的数据。实际上我有 20,000 条记录，每条记录大约有 74 列。因此，使用 ADO 逐条更新它们需要花费大量时间。是否有任何替代方法可以一次性更新这些记录。任何帮助将不胜感激。

目前我的代码是。

    Sub InitialExport()
      On Error GoTo ErrHandler

    Dim con As New ADODB.Connection
    Dim Query As String
    Dim EffectedRecs As Long
    Dim i As Integer

    ServerName = "192.178.78.36"

    'Setting ConnectionString
    con.ConnectionString = "Provider=SQLOLEDB; " & _
            "Data Source=" & ServerName & "; " & _
            "Initial Catalog=AppEmp;" & _
            "User ID=sa; Password=admin08; "

    'Setting provider Name
    con.Provider = "Microsoft.JET.OLEDB.12.0"

    'Opening connection
    con.Open
    With ThisWorkbook.Sheets("Export")
    For i = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
        '---------------------->
        EmpId = .Range("B" & i).Value 'Emp Code-varchar
        C = .Range("C" & i).Value 'Emp Name-varchar
        D = .Range("D" & i).Value 
        E = .Range("E" & i).Value 
        F = .Range("F" & i).Value 
        G = .Range("G" & i).Value 
        H = .Range("H" & i).Value
        II = .Range("I" & i).Value 
        JJ = .Range("J" & i).Value 
        k = .Range("K" & i).Value 
        l = .Range("L" & i).Value 
        M = .Range("M" & i).Value 

        N = CheckNull(.Range("N" & i).Value)
        O = CheckNull(.Range("O" & i).Value) 
        P = CheckNull(.Range("P" & i).Value) 
        Q = CheckNull(.Range("Q" & i).Value) 
        R = CheckNull(.Range("R" & i).Value) 
        S = .Range("S" & i).Value 
        T = .Range("T" & i).Value 
        U = .Range("U" & i).Value 
        v = .Range("V" & i).Value 
        W = .Range("W" & i).Value
        X = CheckNull(.Range("X" & i).Value)

        Y = .Range("Y" & i).Value 
        Z = .Range("Z" & i).Value 
        AA = CheckNull(.Range("AA" & i).Value)
        AB = .Range("AB" & i).Value 
        AC = CheckNull(.Range("AC" & i).Value) 
        AD = CheckNull(.Range("AD" & i).Value) 
        AE = CheckNull(.Range("AE" & i).Value) 
        AF = CheckNull(.Range("AF" & i).Value)
        AG = .Range("AG" & i).Value 
        AH = CheckNull(.Range("AH" & i).Value) 
        AI = CheckNull(.Range("AI" & i).Value) 
        AJ = CheckNull(.Range("AJ" & i).Value) 
        AK = CheckNull(.Range("AK" & i).Value)
        AL = CheckNull(.Range("AL" & i).Value) 
        AM = CheckNull(.Range("AM" & i).Value)
        AN = CheckNull(.Range("AN" & i).Value) 
        AO = CheckNull(.Range("AO" & i).Value) 
        AP = CheckNull(.Range("AP" & i).Value) 
        AQ = CheckNull(.Range("AQ" & i).Value)
        AR = CheckNull(.Range("AR" & i).Value) 
        aAS = CheckNull(.Range("AS" & i).Value) 
        AT = .Range("AT" & i).Value
        AU = CheckNull(.Range("AU" & i).Value) 
        AV = CheckNull(.Range("AV" & i).Value) 
        AW = CheckNull(.Range("AW" & i).Value) 
        AX = CheckNull(.Range("AX" & i).Value) 
        AY = CheckNull(.Range("AY" & i).Value) 
        AZ = CheckNull(.Range("AZ" & i).Value) 
        BA = CheckNull(.Range("BA" & i).Value) 
        BB = CheckNull(.Range("BB" & i).Value)
        BC = CheckNull(.Range("BC" & i).Value) 
        BD = CheckNull(.Range("BD" & i).Value)
        BE = .Range("BE" & i).Value 

        BF = .Range("BF" & i).Value 
        BG = CheckNull(.Range("BG" & i).Value) 
        BH = .Range("BH" & i).Value 
        BI = .Range("BI" & i).Value 
        BJ = CheckNull(.Range("BJ" & i).Value) 
        BK = CheckNull(.Range("BK" & i).Value) 
        BL = CheckNull(.Range("BL" & i).Value) 
        BM = .Range("BM" & i).Value 
        BN = .Range("BN" & i).Value 



        Query = "Exec HRApp_P_AddEmpData '" & EmpId & "','" & C & "','" & D & "','" & E & "','" & F & "','" & G & "','" & H & "','" & II & "','" & JJ & "','" & k & "','" & l & "','" & M & "'," & N & "," & O & "," & P & "," & Q & "," & R & ",'" & S & "','" & T & "','" & U & "','" & v & "','" & W & "'," & X & ",'" & Y & "','" & Z & "'," & AA & ",'" & AB & "'," & AC & "," & AD & "," & AE & "," & AF & ",'" & AG & "'," & AH & "," & AI & "," & AJ & "," & AK & ",'" & AL & "'," & AM & "," & AN & "," & AO & "," & AP & "," & AQ & "," & AR & "," & aAS & ",'" & AT & "'," & AU & "," & AV & "," & AW & "," & AX & "," & AY & "," & AZ & "," & BA & "," & BB & "," & BC & "," & BD & ",'" & BE & "','" & BF & "'," & BG & ",'" & BH & "','" & BI & "'," & BJ & "," & BK & "," & BL & ",'" & BM & "','" & BN & "'"

        con.Execute Query

    Next
    End With

     con.Close
     Set con = Nothing
    Exit Sub
ErrHandler:     'MsgBox "The Not able ta Save Data"

                Set con = Nothing
End Sub

上面的代码工作正常。但是更新数据需要更多时间。:-(

现在我的代码变成了这样

  Private Sub Worksheet_Activate()
    Dim adoConn             As New ADODB.Connection
    Dim adoRS               As New ADODB.Recordset

    Dim sQuery              As String
    Dim EffectedRecs        As Long
    Dim sFields             As String
    Dim sValues             As String

    Dim iRow                As Integer
    Dim iField              As Integer

    ServerName = "193.128.125.14"
    con_Str = "Provider=SQLOLEDB; " & _
            "Data Source=" & ServerName & "; " & _
            "Initial Catalog=DB_At&T;" & _
            "User ID=sa; Password=ad28; "

    sQuery = "select * from Currency where 1=2"

    sValues = ""

    With adoConn
        .ConnectionString = con_Str
        .Provider = "Microsoft.JET.OLEDB.12.0"
        .CursorLocation = adUseClient
        .Open
    End With

    With adoRS
        .ActiveConnection = adoConn
        .CursorLocation = adUseClient
        .LockType = adLockBatchOptimistic
        .CursorType = adOpenKeyset ' adOpenDynamic
        .Source = sQuery
        .Open
    End With

    With ThisWorkbook.Sheets("Export")
        For iRow = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
            For iField = 0 To adoRS.Fields.Count - 1
                sFields = sFields & "," & adoRS.Fields(iField).Name
            Next

            sValues = sValues & "," & .Range("A" & iRow).Value
            sValues = sValues & "," & .Range("B" & iRow).Value
            sValues = sValues & "," & .Range("C" & iRow).Value
            sValues = sValues & "," & .Range("D" & iRow).Value

            sFields = Right(sFields, Len(sFields) - 1) 'Removing ,
            sValues = Right(sValues, Len(sValues) - 1) 'Removing ,
            adoRS.AddNew FieldList = sFields, Values:=sValues
        Next
End With

    adoRS.UpdateBatch adAffectAllChapters

    adoRS.Close
    adoConn.Close
End Sub
4

2 回答 2

1

你可以试试这个：

Sub InitialExport()
On Error GoTo ErrHandler
'
Dim adoConn             As New ADODB.Connection
Dim adoRS               As ADODB.Recordset
'
Dim sQuery              As String
Dim EffectedRecs        As Long
Dim sFields             As String
Dim sValues             As String
'
Dim iRow                As Integer
Dim iField              As Integer
'
ServerName = SERVER_NAME
'
sQuery="SELECT * from tableName where 1 =2" ' get an empty recordset!
'
'Set the connection and open
with adoConn
    .ConnectionString = CONNECTION_STRING
    .Provider = "Microsoft.JET.OLEDB.12.0"
    .cursorlocation=aduseclient
    .Open
end with
'
' set the Recordset and open
With adoRS
    .activeconnection=adoconn
    .CursorLocation = adUseClient
    .LockType = adLockBatchOptimistic
    .CursorType = adopenkeyset ' adOpenDynamic
    .Source = sQuery
    .Open
End With
'
' now get the data into the recordset
With ThisWorkbook.Sheets("Export")
    For iRow = 3 To ThisWorkbook.Sheets("Export").Range("B65536").End(xlUp).Row
        ' here loop through all the columns
        For iField = 0 To adoRS.Fields.Count - 1
            ' adding the column names to the Variable sFields
            sFields = sFields & "," & adoRS.Fields(iField).Name
            '
            ' adding the values from the worksheet for this row
            sValues = sValues & ", " & .Cells(iRow, iField).Text
        Next
        '
        ' add a new record with the fields and values
        adoRS.AddNew FieldList:=sFields, Values:=sValues
        '
Next
'
' update all the rows in one step
adoRS.UpdateBatch adAffectAllChapters ' update them all in one step!
'
End Sub

只需将查询中的表名更改为正确的表，并确保工作表中的列与表中的列具有相同的顺序和数据类型

有关 ADO 记录集的帮助，请参阅：

MSDN 库 - ADO 记录集、AddNew 方法

和

MSDN 库 - ADO 记录集、UpdateBatch

和

W3学校

我希望你开始了！

菲利普

于 2013-03-13T15:14:16.283 回答
1

另一种选择是使用BulkInsert将整个 Excel 工作表作为 csv 文件直接上传到服务器。

Sql 代码可能看起来很简单：

BULK INSERT [DB].[dbo].[Importa_Aux] FROM '\\share\filename.csv' WITH ( FIELDTERMINATOR = ',' , ROWTERMINATOR = '\n' , FIRSTROW = 2 )

然后只需在 SqlServer 中进行数据更新。

于 2017-01-23T15:47:58.050 回答