VBA 将数据推送到数据库中

Question

我有一个数据表，其中只有几列：GLID、Metric Category、Amount 和 Metric Date。在我需要使用的 excel 文件中组织数据的方式就像一个矩阵，如下所示：

日期列是公制日期，其下方的数字是金额。正如您所看到的，每个日期都有一些与特定指标类别相关的数量，在某些情况下是 GLID。现在我需要在 VBA 中将数据推送到格式中

GLID       Metric Category         Amount          Metric Date
5500       Property Tax-5500        -8               3/31/2020
5500       Property Tax-5500        -8               4/30/2020

如此等等。我对 VBA 完全陌生，所以这个特殊的任务对我来说是令人生畏和具有挑战性的，这也是我在这里发帖的原因。如果有人有一些建议，我将不胜感激。

到目前为止，这是我在 VBA 中的设置：

Sub second_export()
Dim sSQL As String, sCnn As String, sServer As String
    Dim db As Object, rs As Object
    sServer = "CATHCART"
    sCnn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Portfolio_Analytics;Data Source=" & sServer & ";" & _
              "Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;"

    Set db = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    If db.State = 0 Then db.Open sCnn




End Sub

进一步说明：

excel文件中列数为36行数为46。对于没有 GLID 的类别，如果需要，我们可以推送 NULL。

我可以简单地将数据推送到数据库中并插入，但我必须旋转数据，以便 GLID 和 Metric 类别在其关联的日期和数量上重复。

Answer 1

首先创建一张要上传的数据表

Option Explicit
Sub CreateDataSheet()

    Dim wb As Workbook, ws As Worksheet, wsData As Worksheet, header As Variant
    Dim iLastRow, iLastCol, dt As Variant, iOutRow
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' the matrix sheet
    Set wsData = wb.Sheets("Sheet2") ' sheet to hold table data

    wsData.Cells.Clear
    wsData.Range("A1:D1") = Array("GLID", "Metric Category", "Amount", "Metric Date")

    ' get header
    iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    header = ws.Range(ws.Cells(1, 3), ws.Cells(1, iLastCol))
    'Debug.Print iLastRow, iLastCol, UBound(header, 2)

    Dim r, c
    iOutRow = 2
    For r = 2 To iLastRow
        For c = 1 To UBound(header, 2)
            'Debug.Print r, header(1, c), ws.Cells(r, c + 2)
            With wsData.Cells(iOutRow, 1)
                .Offset(0, 0) = ws.Cells(r, 1)
                .Offset(0, 1) = ws.Cells(r, 2)
                .Offset(0, 2) = ws.Cells(r, c + 2)
                .Offset(0, 3) = header(1, c)
            End With
            iOutRow = iOutRow + 1
        Next
    Next
    wsData.Range("A1").Select
    MsgBox iOutRow - 2 & " Rows created on " & wsData.Name, vbInformation

End Sub

然后在数据库中创建一个表

Sub CreateTable()

    Const TABLE_NAME = "dbo.GL_TEST"
    Dim SQL As String, con As Object

    SQL = "CREATE TABLE " & TABLE_NAME & "( " & vbCr & _
          "RECNO int NOT NULL," & vbCr & _
          "GLID nchar(10)," & vbCr & _
          "METRICNAME nvarchar(255)," & vbCr & _
          "AMOUNT money," & vbCr & _
          "METRICDATE date," & vbCr & _
          "PRIMARY KEY (RECNO))"

     'Debug.Print sql
     Set con = mydbConnect()
     'con.Execute ("DROP TABLE " & TABLE_NAME) ' use during testing
     con.Execute SQL
     con.Close
     Set con = Nothing

     MsgBox "Table " & TABLE_NAME & " created"

End Sub

使用数据连接。

Function mydbConnect() As Object
    Dim sConStr As String

    Const sServer = "CATHCART"
    sConStr = "Provider=SQLOLEDB.1;" & _
              "Integrated Security=SSPI;" & _
              "Persist Security Info=True;" & _
              "Initial Catalog=Portfolio_Analytics;" & _
              "Data Source=" & sServer & ";" & _
              "Use Procedure for Prepare=1;" & _
              "Auto Translate=True;Packet Size=4096;"

    Set mydbConnect = CreateObject("ADODB.Connection")
    mydbConnect.Open sConStr

End Function    

然后在关闭自动提交的情况下一次从工作表中加载一条记录。

Sub LoadData()

    Const TABLE_NAME = "dbo.GL_TEST"

    Dim SQL As String
    SQL = " INSERT INTO " & TABLE_NAME & _
          " (RECNO,GLID,METRICNAME,AMOUNT,METRICDATE) VALUES (?,?,?,?,?) "

    Dim con As Object, cmd As Object, rs As Variant
    Set con = mydbConnect()
    Set cmd = CreateObject("ADODB.Command")

    With cmd
        .ActiveConnection = con
        .CommandType = adCmdText
        .CommandText = SQL
        .Parameters.Append .CreateParameter("P1", adInteger, adParamInput)
        .Parameters.Append .CreateParameter("P2", adVarWChar, adParamInput, 10)
        .Parameters.Append .CreateParameter("P3", adVarWChar, adParamInput, 255)
        .Parameters.Append .CreateParameter("P4", adCurrency, adParamInput)
        .Parameters.Append .CreateParameter("P5", adDate, adParamInput)
    End With

    con.Execute "SET IMPLICIT_TRANSACTIONS ON"

    Dim ws As Worksheet, iLastRow As Long, i As Long
    Set ws = ThisWorkbook.Sheets("Sheet2") ' sheet were table data is
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To iLastRow
        cmd.Parameters(0).Value = i
        cmd.Parameters(1).Value = ws.Cells(i, 1)
        cmd.Parameters(2).Value = ws.Cells(i, 2)
        cmd.Parameters(3).Value = ws.Cells(i, 3)
        cmd.Parameters(4).Value = ws.Cells(i, 4)
        cmd.Execute
    Next

    con.Execute "COMMIT"
    con.Execute "SET IMPLICIT_TRANSACTIONS OFF"

    rs = con.Execute("SELECT COUNT(*) FROM " & TABLE_NAME)
    MsgBox rs(0) & " Rows are in " & TABLE_NAME, vbInformation

    con.Close
    Set con = Nothing

End Sub

Answer 2

以下是循环数据的方法：

Sub Tester()

    Dim rw As Range, n As Long
    Dim GLID, category, dt, amount

    For Each rw In ActiveSheet.Range("H2:AS47").Rows 

        'fixed per-row
        GLID = Trim(rw.Cells(1).Value)
        category = Trim(rw.Cells(2).Value)

        'loopover the date columns
        For n = 3 To rw.Cells.Count

            dt = rw.Cells(n).EntireColumn.Cells(1).Value 'date from Row 1
            amount = rw.Cells(n).Value

            Debug.Print rw.Cells(n).Address, GLID, category, amount, dt

            'insert a record using your 4 values
            'switch GLID to null if empty

        Next n
    Next rw

End Sub