Attribute VB_Name = "ExcelToSql"
Option Explicit

' Генерит SQL из листов книги: таблицы, справочники, представления, данные.
' Запуск: Alt+F8 -> GenerateSql.

Public Sub GenerateSql()
    Dim wb As Workbook, ws As Worksheet, sql As String, dbName As String
    Set wb = ActiveWorkbook

    dbName = InputBox("Имя базы данных на сервере:", "Генератор SQL", "ExamDb")
    If Len(dbName) = 0 Then Exit Sub

    sql = "IF DB_ID(N'" & dbName & "') IS NULL CREATE DATABASE [" & dbName & "];" & vbCrLf & "GO" & vbCrLf
    sql = sql & "USE [" & dbName & "];" & vbCrLf & "GO" & vbCrLf & vbCrLf

    For Each ws In wb.Worksheets
        If Trim(CStr(ws.Cells(1, 1).Value)) <> "" Then
            sql = sql & BuildSheet(ws) & vbCrLf
        End If
    Next ws

    WriteUtf8 wb.Path & "\generated.sql", sql
    MsgBox "Готово:" & vbCrLf & wb.Path & "\generated.sql", vbInformation
End Sub

Private Function BuildSheet(ws As Worksheet) As String
    Dim lastC As Long, lastR As Long, c As Long, r As Long
    lastC = LastCol(ws): lastR = LastRow(ws)

    Dim typ() As String, isDict() As Boolean, nm() As String
    ReDim typ(1 To lastC): ReDim isDict(1 To lastC): ReDim nm(1 To lastC)
    For c = 1 To lastC
        nm(c) = CStr(ws.Cells(1, c).Value)
        typ(c) = ColType(ws, c, lastR)
        isDict(c) = (InStr(typ(c), "VARCHAR") > 0) And IsDictionary(ws, c, lastR)
    Next c

    Dim s As String
    s = "-- " & ws.Name & vbCrLf

    ' 1) Справочники
    For c = 1 To lastC
        If isDict(c) Then
            s = s & "IF OBJECT_ID('[" & nm(c) & "]','U') IS NULL CREATE TABLE [" & nm(c) & "] " & _
                    "([Id] INT IDENTITY(1,1) CONSTRAINT [PK_" & nm(c) & "] PRIMARY KEY, [Name] NVARCHAR(255) NOT NULL CONSTRAINT [UQ_" & nm(c) & "] UNIQUE);" & vbCrLf
            Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
            For r = 2 To lastR
                Dim val As String: val = CStr(ws.Cells(r, c).Value)
                If Len(val) > 0 Then If Not d.Exists(val) Then d.Add val, 1
            Next r
            Dim k As Variant
            For Each k In d.Keys
                s = s & "INSERT INTO [" & nm(c) & "] ([Name]) SELECT N'" & Esc(CStr(k)) & "' " & _
                        "WHERE NOT EXISTS (SELECT 1 FROM [" & nm(c) & "] WHERE [Name]=N'" & Esc(CStr(k)) & "');" & vbCrLf
            Next k
            s = s & "GO" & vbCrLf
        End If
    Next c

    ' 2) Основная таблица
    s = s & "CREATE TABLE [" & ws.Name & "] (" & vbCrLf & "  [Id] INT IDENTITY(1,1) CONSTRAINT [PK_" & ws.Name & "] PRIMARY KEY," & vbCrLf
    For c = 1 To lastC
        If isDict(c) Then
            s = s & "  [" & nm(c) & "_id] INT NULL CONSTRAINT [FK_" & ws.Name & "_" & nm(c) & "] REFERENCES [" & nm(c) & "]([Id])"
        Else
            s = s & "  [" & nm(c) & "] " & typ(c)
        End If
        If c < lastC Then s = s & ","
        s = s & vbCrLf
    Next c
    s = s & ");" & vbCrLf & "GO" & vbCrLf

    ' 3) Данные основной таблицы
    Dim cols As String
    cols = ""
    For c = 1 To lastC
        cols = cols & IIf(isDict(c), "[" & nm(c) & "_id]", "[" & nm(c) & "]")
        If c < lastC Then cols = cols & ", "
    Next c
    For r = 2 To lastR
        Dim vals As String: vals = ""
        For c = 1 To lastC
            If isDict(c) Then
                Dim dv As String: dv = CStr(ws.Cells(r, c).Value)
                If Len(dv) = 0 Then
                    vals = vals & "NULL"
                Else
                    vals = vals & "(SELECT [Id] FROM [" & nm(c) & "] WHERE [Name]=N'" & Esc(dv) & "')"
                End If
            Else
                vals = vals & SqlVal(ws.Cells(r, c).Value, typ(c))
            End If
            If c < lastC Then vals = vals & ", "
        Next c
        s = s & "INSERT INTO [" & ws.Name & "] (" & cols & ") VALUES (" & vals & ");" & vbCrLf
    Next r
    s = s & "GO" & vbCrLf

    ' 4) Представление (исходные имена колонок -> для DataSet/AlfaToad)
    s = s & "IF OBJECT_ID('[vw_" & ws.Name & "]','V') IS NOT NULL DROP VIEW [vw_" & ws.Name & "];" & vbCrLf & "GO" & vbCrLf
    s = s & "CREATE VIEW [vw_" & ws.Name & "] AS SELECT" & vbCrLf
    For c = 1 To lastC
        If isDict(c) Then
            s = s & "  d" & c & ".[Name] AS [" & nm(c) & "]"
        Else
            s = s & "  t.[" & nm(c) & "]"
        End If
        If c < lastC Then s = s & ","
        s = s & vbCrLf
    Next c
    s = s & "FROM [" & ws.Name & "] t" & vbCrLf
    For c = 1 To lastC
        If isDict(c) Then s = s & "  LEFT JOIN [" & nm(c) & "] d" & c & " ON d" & c & ".[Id]=t.[" & nm(c) & "_id]" & vbCrLf
    Next c
    s = s & ";" & vbCrLf & "GO" & vbCrLf

    BuildSheet = s
End Function

' Справочник: текст с низкой кардинальностью (повторяется).
' Колонки с запятыми (составные списки, адреса) в справочники НЕ выносим.
Private Function IsDictionary(ws As Worksheet, c As Long, lastR As Long) As Boolean
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim r As Long, v As String, rows As Long, hasComma As Boolean
    rows = 0: hasComma = False
    For r = 2 To lastR
        v = CStr(ws.Cells(r, c).Value)
        If Len(v) > 0 Then
            rows = rows + 1
            If InStr(v, ",") > 0 Then hasComma = True
            If Not d.Exists(v) Then d.Add v, 1
        End If
    Next r
    IsDictionary = (Not hasComma) And (d.Count >= 1) And (d.Count <= 50) And (d.Count <= rows * 0.6)
End Function

Private Function LastCol(ws As Worksheet) As Long
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
End Function

Private Function LastRow(ws As Worksheet) As Long
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
End Function

Private Function ColType(ws As Worksheet, c As Long, lastR As Long) As String
    Dim r As Long, v As Variant, sv As String
    Dim hasData As Boolean, allDate As Boolean, allInt As Boolean, allNum As Boolean
    Dim maxLen As Long, hasNonAscii As Boolean, maxAbs As Double
    hasData = False: allDate = True: allInt = True: allNum = True
    maxLen = 0: hasNonAscii = False: maxAbs = 0
    For r = 2 To lastR
        v = ws.Cells(r, c).Value
        sv = CStr(v)
        If Len(sv) > 0 Then
            hasData = True
            Select Case VarType(v)
                Case vbDate
                    allInt = False: allNum = False
                Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
                    allDate = False
                    If v <> Int(v) Then allInt = False
                    If Abs(v) > maxAbs Then maxAbs = Abs(v)
                Case Else
                    allDate = False: allInt = False: allNum = False
            End Select
            If Len(sv) > maxLen Then maxLen = Len(sv)
            If Not hasNonAscii Then hasNonAscii = HasNonAscii(sv)
        End If
    Next r
    If Not hasData Then ColType = "NVARCHAR(255) NULL": Exit Function
    If allDate Then ColType = "DATE NULL": Exit Function
    If allInt Then
        If maxAbs > 2147483647# Then ColType = "BIGINT NULL" Else ColType = "INT NULL"
        Exit Function
    End If
    If allNum Then ColType = "DECIMAL(18,2) NULL": Exit Function
    ' Текст: кириллица -> NVARCHAR, только латиница -> VARCHAR; длина по факту
    Dim baseType As String
    If hasNonAscii Then baseType = "NVARCHAR" Else baseType = "VARCHAR"
    ColType = baseType & "(" & Bucket(maxLen) & ") NULL"
End Function

Private Function HasNonAscii(ByVal s As String) As Boolean
    Dim i As Long
    For i = 1 To Len(s)
        If AscW(Mid$(s, i, 1)) > 127 Then HasNonAscii = True: Exit Function
    Next i
    HasNonAscii = False
End Function

' Длина строкового типа: ближайший «разумный» размер >= факт. максимума
Private Function Bucket(ByVal n As Long) As String
    Dim sizes As Variant, x As Variant
    sizes = Array(10, 20, 30, 50, 100, 150, 200, 255, 500, 1000, 2000, 4000)
    For Each x In sizes
        If n <= x Then Bucket = CStr(x): Exit Function
    Next x
    Bucket = "MAX"
End Function

Private Function SqlVal(v As Variant, t As String) As String
    If Len(CStr(v)) = 0 Then SqlVal = "NULL": Exit Function
    If Left$(t, 4) = "DATE" Then SqlVal = "'" & Format$(v, "yyyy-mm-dd") & "'": Exit Function
    If InStr(t, "INT") > 0 Or Left$(t, 7) = "DECIMAL" Then SqlVal = Replace(CStr(v), ",", "."): Exit Function
    SqlVal = "N'" & Esc(CStr(v)) & "'"
End Function

Private Function Esc(ByVal s As String) As String
    Esc = Replace(s, "'", "''")
End Function

Private Sub WriteUtf8(ByVal path As String, ByVal text As String)
    Dim st As Object
    Set st = CreateObject("ADODB.Stream")
    st.Type = 2
    st.Charset = "utf-8"
    st.Open
    st.WriteText text
    st.SaveToFile path, 2
    st.Close
End Sub