После подключения ODBC - MySQL из Excel VBA я могу искать, обновлять, но не могу вставить - PullRequest
Новая
       19

После подключения ODBC - MySQL из Excel VBA я могу искать, обновлять, но не могу вставить

0 голосов
/ 24 сентября 2019

У меня есть программа VBA, которая запрограммирована другим человеком.Я могу подключиться к серверу MySQL-MariaDB через ODBC-соединение.

Обычно программа позволяет пользователю выбирать файл Excel для загрузки данных.В коде я не могу найти, почему я не могу вставить данные в сервер базы данных, несколько месяцев назад это работало хорошо.

В ожидании некоторых советов по исправлению кода.

В Windows 10 Office 365 Excel я использую драйвер ODBC 8.0 ANSI в качестве драйвера, сервер БД, расположенный на NAS в сети

Несколько месяцев назад, как в июле, я могу вставить данные с помощью этого кода, но теперь я не могу 

Sub Main_Sales_Upload()

    Dim i As Double, i2 As Double, i3 As Double, cntR As Double, cntC As Double, cntRecord As Double, FindR As Double
    Dim str_File As String
    Dim Fd As FileDialog

    Dim rng As Range
    Dim Var_DB() As Variant, Var_Temp() As Variant, Var_Result() As Variant
    Dim Result As Variant

    If MsgBox("You want upload SalesHistory?", vbQuestion + vbOKCancel, "") = vbCancel Then Exit Sub
    Set Fd = Application.FileDialog(msoFileDialogFilePicker)
    With Fd
        .AllowMultiSelect = False
        .Show

        If .SelectedItems.Count = 0 Then Exit Sub
        str_File = .SelectedItems(1)
    End With

Application.ScreenUpdating = False
    Workbooks.Open str_File, False

        Columns(1).NumberFormatLocal = "YYYY-MM-DD"

        cntR = Cells(Rows.Count, 1).End(xlUp).Row
        cntC = Cells(2, Columns.Count).End(xlToLeft).Column

        Set rng = Range(Cells(3, 1), Cells(cntR, 1))
        For Each rng In rng
            If Cells(rng.Row, 2).Value <> "" Then
                i = i + 1

                For i2 = 1 To cntC
                    If IsError(Cells(rng.Row, i2).Value) = True Then
                        Cells(rng.Row, i2).Value = ""
                    End If

                    ReDim Preserve Var_DB(1 To cntC, 1 To i)
                    Var_DB(i2, i) = Cells(rng.Row, i2).Value
                Next i2
            End If
        Next

    ActiveWorkbook.Close False
    cntRecord = i

    If cntRecord = 0 Then
        MsgBox "No Data", vbCritical, ""
        Exit Sub
    End If

Application.ScreenUpdating = True

    Progressbar.Show 0

    For i = 1 To cntRecord
        DoEvents

        If Var_DB(41, i) = 99 Then
            Var_DB(66, i) = "Clinic"
        ElseIf Var_DB(41, i) = 35 Then
            Var_DB(66, i) = "Alloy"
        Else
            FindR = Find_Direction(Map.Columns("M"), Left(Var_DB(65, i), 1), 1)
            If FindR > 0 Then
                Var_DB(66, i) = Map.Cells(FindR, "O").Value
            Else
                FindR = Find_Direction(Map.Columns("M"), Left(Var_DB(65, i), 2), 1)
                If FindR > 0 Then
                    Var_DB(66, i) = Map.Cells(FindR, "O").Value
                End If
            End If
        End If

        With Progressbar
            .Bar_Fill.Width = .Bar.Width * (i / cntRecord)
            .Pct.Caption = Format((i / cntRecord), "0%")
        End With

        ReDim Var_Temp(1 To UBound(Var_DB))

        For i2 = 1 To UBound(Var_DB)
            If IsError(Var_DB(i2, i)) = True Then
                Var_Temp(i2) = "''"
            Else
                Var_Temp(i2) = "'" & Replace(Var_DB(i2, i), "'", "") & "'"
            End If
        Next i2

        i3 = i3 + 1
        ReDim Preserve Var_Result(1 To i3)
        Var_Result(i3) = "(" & Join(Var_Temp, ",") & ")"

    Next i

    Unload Progressbar

    Result = MySQL_Connection(Method:="Insert", Table:="Database_Sales", DB_A:=Var_Result)
    MsgBox "Upload Successful.", vbInformation, ""

End Sub

Я хотел бы загрузить Excel для вставки данных на сервер БД. Нет сообщений об ошибках от программы,ни в DB

...