VBA Exporter Excel en SQL

Posté le par

Macro qui exporte chaque tableau d'un classeur en SQL.

  • Les noms de tableau servent de nom de table
  • Les colonnes commençant par 1 sont considérées comme INTEGER avec AUTOINCREMENT
  • les dates sont formatées en aaaa-mm-jj
  • Les apostrophes des cellules sont "échappées"
  • les cellules vides sont mise à Null
  • L'export se fait en UTF-8

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
'*******************
'Exporte les données en sql
'vers la fenêtre d'exécution (debug.print)
'les noms des tableaux servent de nom de table
'pas les noms de feuilles
'si une colonne commence par 1
'on suppose qu'il s'agit d'une clé primaire avec autoincrement
'*******************
 
Sub exportSQL()
 
    'les deux parties du sql (déclaration des tables, valeurs à insérer)
    Dim sql_tb, sql_val, auto_inc, data_type As String
    'chr(34) = guillemet
    'chaque feuille du classeur
    For Each ws In ActiveWorkbook.Sheets
        'chaque tableau de la feuille
        For Each tb In ws.ListObjects
            'sauter pdl
            If tb.Name = "Tableau6" Then Exit For
            auto_inc = ""
            sql_tb = sql_tb & vbCrLf & "CREATE TABLE IF NOT EXISTS " & Chr(34) & tb.Name & Chr(34) & "(" & vbCrLf
             
            'chaque colonne du tableau
            For Each c In tb.ListColumns
                '*** partie Déclaration des tables
                'on détecte une clé primaire à autoincrémenter
                If c.Range(2) = 1 Then auto_inc = vbTab & "PRIMARY KEY(" & Chr(34) & c.Name & Chr(34) & " AUTOINCREMENT)" & vbCrLf
                'on évite de mettre une virgule après la dernière colonne
                 
                If estDernière(c) = True And auto_inc = "" Then sep = "" Else sep = ","
                'on définit le type de donnée à déclarer
                If IsDate(c.Range(2)) Then
                    data_type = "DATETIME"
                ElseIf c.Range(2) = 1 Then
                    data_type = "INTEGER"
                ElseIf IsNumeric(c.Range(2)) Then
                    data_type = "NUMERIC"
                Else
                    data_type = "TEXT"
                End If
                sql_tb = sql_tb & vbTab & Chr(34) & c.Name & Chr(34) & " " & data_type & sep & vbCrLf
            Next c
            sql_tb = sql_tb & auto_inc & ");" & vbCrLf
             
            If tb.ListRows.Count = 0 Then Exit For
            '*** partie valeurs à insérer
            sql_val = sql_val & vbCrLf & "INSERT INTO " & tb.Name & " VALUES" & vbCrLf
            For Each r In tb.ListRows
                sql_val = sql_val & "("
                For i = 1 To tb.ListColumns.Count
                    'si c'est la dernière colonne on mettra une virgule
                    If i = tb.ListColumns.Count Then sep = "" Else sep = ","
                    'on met des apostrophes autour des dates et du texte
                    If IsDate(r.Range(i)) = True Or Not IsNumeric(r.Range(i)) Then apo = "'" Else apo = ""
                    'on met les dates en format
                    If IsDate(r.Range(i)) Then myval = Format(r.Range(i), "yyyy-mm-dd") Else myval = r.Range(i).Value
                    If r.Range(i) = "" Then myval = "Null"
                    'on échappe les apostrophes du texte
                    If InStr(myval, "'") > 0 Then myval = Replace(myval, "'", "''")
                    sql_val = sql_val & apo & myval & apo & sep
                Next i
                If r.Index = tb.ListRows.Count Then sep = "" Else sep = ","
                sql_val = sql_val & ")" & sep & vbCrLf
            Next r
            sql_val = sql_val & ";"
        Next tb
    Next ws
     
    'on définit un fichier de destination
    'gardé en mémoire tant que le fichier est ouvert
    Static destPath As String
    'si l
    If destPath = "" Then
        With Application.FileDialog(msoFileDialogFilePicker)
            .Show
            destPath = .SelectedItems(1)
        End With
    End If
     
     
    Dim fsT As Object
    Set fsT = CreateObject("ADODB.Stream")
    fsT.Type = 2 'Specify stream type - we want To save text/string data.
    fsT.Charset = "utf-8" 'Specify charset For the source text data.
    fsT.Open 'Open the stream And write binary data To the object
    fsT.WriteText sql_tb & vbCrLf & sql_val
    fsT.SaveToFile destPath, 2 'Save binary data To disk
    
     
        msgbox "Export terminé avec succès!"
End Sub
 
Function estDernière(ByVal c As ListColumn) As String
    If c.Index = c.Parent.ListColumns.Count Then
    estDernière = True
    Else
    estDernière = False
    End If
End Function
Partagez:

Ceci pourrait aussi vous intéresser: