【VBA】将数组上传到数据表自定义函数

'将数组arr上传到cnt的tablename表中，dic_field_mapping中key是arr的标题，value是database中的对应标题
'其中arr必须带字段，否则无法匹配上传
'如果dic_field_mapping为nothing，默认数组的字段和数据库中的相同
'如果tracking_id为0，则不管tracking_id的上传，如果不为0，则上传到名为tracking_id的字段
'By Dawei GAO，2020-11-13
Sub ArrayToDatatable(ByVal arr As Variant, ByVal tablename As String, cnt As Object, Optional ByVal dic_field_mapping As Object = Nothing, _
    Optional ByVal chunck_size As Long = 1000, Optional tracking_id As Long = 0)
  Dim sql As String, rst As Object
  Dim ro As Long, lstro As Long
  Dim col As Long, lstcol As Long
  Dim field As Variant
  Dim dic_fields As Object
  
  Set rst = CreateObject("adodb.recordset")
  lstro = UBound(arr, 1)
  lstcol = UBound(arr, 2)
  If dic_field_mapping Is Nothing Then
    Set dic_field_mapping = CreateObject("scripting.dictionary")
    For col = 1 To lstcol
      dic_field_mapping(arr(1, col)) = arr(1, col)
    Next col
  Else
    For col = 1 To lstcol
      If Not dic_field_mapping.exists(arr(1, col)) Then
        dic_field_mapping(arr(1, col)) = arr(1, col)
      End If
    Next col
  End If
  '
  sql = StringFormat("select * from {0} where 1=2", tablename)
  rst.Open sql, cnt, 1, 3
  Set dic_fields = GetFieldsCollectionFromRecordset(rst)
  '上传数据
  With rst
    If tracking_id = 0 Then
      For ro = 2 To lstro
        .AddNew
        For col = 1 To lstcol
          If dic_field_mapping.exists(arr(1, col)) Then
            field = dic_field_mapping(arr(1, col))
            If dic_fields.exists(field) Then  '数据库中有这个字段才上传
              .Fields(field) = arr(ro, col)
            End If
          End If
        Next
        If (ro Mod chunck_size = 1) Or (ro = lstro) Then
          .Update
        End If
      Next ro
    Else
      For ro = 2 To lstro
        .AddNew
        For col = 1 To lstcol
          If dic_field_mapping.exists(arr(1, col)) Then
            field = dic_field_mapping(arr(1, col))
            If dic_fields.exists(field) Then  '数据库中有这个字段才上传
              .Fields(field) = arr(ro, col)
            End If
          End If
        Next
        .Fields("tracking_id") = tracking_id
        If (ro Mod chunck_size = 1) Or (ro = lstro) Then
          .Update
        End If
      Next ro
    End If
    .Close
  End With
End Sub