Attribute VB_Name = "ToyWorldDb" Option Explicit ' Тема "игрушки": схема БД зашита, данные берутся из листов книги. ' Листы определяются по заголовкам: товары / пользователи / заказы / пункты выдачи. ' Результат -> generated.sql рядом с книгой. Запуск: Alt+F8 -> GenerateToyDb. Private buf As String Public Sub GenerateToyDb() buf = "" Emit SchemaSql() SeedSql Emit ViewsSql() WriteUtf8 ActiveWorkbook.Path & "\generated.sql", buf MsgBox "Готово:" & vbCrLf & ActiveWorkbook.Path & "\generated.sql", vbInformation End Sub Private Sub Emit(ByVal s As String) buf = buf & s & vbCrLf End Sub Private Function SchemaSql() As String Dim s As String s = "IF DB_ID('ToyWorldDb') IS NULL CREATE DATABASE ToyWorldDb;" & vbCrLf & "GO" & vbCrLf s = s & "USE ToyWorldDb;" & vbCrLf & "GO" & vbCrLf s = s & "IF OBJECT_ID('dbo.OrderItem','U') IS NOT NULL DROP TABLE dbo.OrderItem;" & vbCrLf s = s & "IF OBJECT_ID('dbo.[Order]','U') IS NOT NULL DROP TABLE dbo.[Order];" & vbCrLf s = s & "IF OBJECT_ID('dbo.Product','U') IS NOT NULL DROP TABLE dbo.Product;" & vbCrLf s = s & "IF OBJECT_ID('dbo.[User]','U') IS NOT NULL DROP TABLE dbo.[User];" & vbCrLf s = s & "IF OBJECT_ID('dbo.PickupPoint','U') IS NOT NULL DROP TABLE dbo.PickupPoint;" & vbCrLf s = s & "IF OBJECT_ID('dbo.OrderStatus','U') IS NOT NULL DROP TABLE dbo.OrderStatus;" & vbCrLf s = s & "IF OBJECT_ID('dbo.Category','U') IS NOT NULL DROP TABLE dbo.Category;" & vbCrLf s = s & "IF OBJECT_ID('dbo.Manufacturer','U') IS NOT NULL DROP TABLE dbo.Manufacturer;" & vbCrLf s = s & "IF OBJECT_ID('dbo.Supplier','U') IS NOT NULL DROP TABLE dbo.Supplier;" & vbCrLf s = s & "IF OBJECT_ID('dbo.Unit','U') IS NOT NULL DROP TABLE dbo.Unit;" & vbCrLf s = s & "IF OBJECT_ID('dbo.Role','U') IS NOT NULL DROP TABLE dbo.Role;" & vbCrLf & "GO" & vbCrLf s = s & "CREATE TABLE dbo.Role (RoleId INT IDENTITY(1,1) CONSTRAINT PK_Role PRIMARY KEY, RoleName NVARCHAR(50) NOT NULL CONSTRAINT UQ_Role UNIQUE);" & vbCrLf s = s & "CREATE TABLE dbo.Unit (UnitId INT IDENTITY(1,1) CONSTRAINT PK_Unit PRIMARY KEY, UnitName NVARCHAR(20) NOT NULL CONSTRAINT UQ_Unit UNIQUE);" & vbCrLf s = s & "CREATE TABLE dbo.Supplier (SupplierId INT IDENTITY(1,1) CONSTRAINT PK_Supplier PRIMARY KEY, SupplierName NVARCHAR(100) NOT NULL CONSTRAINT UQ_Supplier UNIQUE);" & vbCrLf s = s & "CREATE TABLE dbo.Manufacturer (ManufacturerId INT IDENTITY(1,1) CONSTRAINT PK_Manufacturer PRIMARY KEY, ManufacturerName NVARCHAR(100) NOT NULL CONSTRAINT UQ_Manufacturer UNIQUE);" & vbCrLf s = s & "CREATE TABLE dbo.Category (CategoryId INT IDENTITY(1,1) CONSTRAINT PK_Category PRIMARY KEY, CategoryName NVARCHAR(100) NOT NULL CONSTRAINT UQ_Category UNIQUE);" & vbCrLf s = s & "CREATE TABLE dbo.OrderStatus (StatusId INT IDENTITY(1,1) CONSTRAINT PK_OrderStatus PRIMARY KEY, StatusName NVARCHAR(50) NOT NULL CONSTRAINT UQ_OrderStatus UNIQUE);" & vbCrLf & "GO" & vbCrLf s = s & "CREATE TABLE dbo.[User] (UserId INT IDENTITY(1,1) CONSTRAINT PK_User PRIMARY KEY, RoleId INT NOT NULL CONSTRAINT FK_User_Role REFERENCES dbo.Role(RoleId), FullName NVARCHAR(150) NOT NULL, Login NVARCHAR(100) NOT NULL CONSTRAINT UQ_User_Login UNIQUE, Password NVARCHAR(100) NOT NULL);" & vbCrLf s = s & "CREATE TABLE dbo.PickupPoint (PickupPointId INT NOT NULL CONSTRAINT PK_PickupPoint PRIMARY KEY, PostalCode NVARCHAR(10) NOT NULL, City NVARCHAR(80) NOT NULL, Street NVARCHAR(120) NOT NULL, House NVARCHAR(20) NOT NULL);" & vbCrLf s = s & "CREATE TABLE dbo.Product (ProductId INT IDENTITY(1,1) CONSTRAINT PK_Product PRIMARY KEY, Article NVARCHAR(10) NOT NULL CONSTRAINT UQ_Product_Article UNIQUE, Name NVARCHAR(255) NOT NULL, UnitId INT NOT NULL CONSTRAINT FK_Product_Unit REFERENCES dbo.Unit(UnitId), Price DECIMAL(10,2) NOT NULL CONSTRAINT CK_Price CHECK (Price>=0), SupplierId INT NOT NULL CONSTRAINT FK_Product_Supplier REFERENCES dbo.Supplier(SupplierId), ManufacturerId INT NOT NULL CONSTRAINT FK_Product_Manufacturer REFERENCES dbo.Manufacturer(ManufacturerId), CategoryId INT NOT NULL CONSTRAINT FK_Product_Category REFERENCES dbo.Category(CategoryId), Discount INT NOT NULL CONSTRAINT CK_Disc CHECK (Discount BETWEEN 0 AND 100), Stock INT NOT NULL CONSTRAINT CK_Stock CHECK (Stock>=0), Description NVARCHAR(MAX) NULL, Photo NVARCHAR(100) NULL);" & vbCrLf s = s & "CREATE TABLE dbo.[Order] (OrderId INT NOT NULL CONSTRAINT PK_Order PRIMARY KEY, OrderDate DATE NULL, DeliveryDate DATE NULL, PickupPointId INT NOT NULL CONSTRAINT FK_Order_Pickup REFERENCES dbo.PickupPoint(PickupPointId), ClientUserId INT NULL CONSTRAINT FK_Order_User REFERENCES dbo.[User](UserId), ReceiveCode INT NULL, StatusId INT NOT NULL CONSTRAINT FK_Order_Status REFERENCES dbo.OrderStatus(StatusId));" & vbCrLf s = s & "CREATE TABLE dbo.OrderItem (OrderItemId INT IDENTITY(1,1) CONSTRAINT PK_OrderItem PRIMARY KEY, OrderId INT NOT NULL CONSTRAINT FK_Item_Order REFERENCES dbo.[Order](OrderId) ON DELETE CASCADE, Article NVARCHAR(10) NOT NULL CONSTRAINT FK_Item_Product REFERENCES dbo.Product(Article), Quantity INT NOT NULL CONSTRAINT CK_Qty CHECK (Quantity>0), CONSTRAINT UQ_Item UNIQUE (OrderId, Article));" & vbCrLf & "GO" & vbCrLf SchemaSql = s End Function Private Function ViewsSql() As String Dim s As String s = "IF OBJECT_ID('dbo.vCatalog','V') IS NOT NULL DROP VIEW dbo.vCatalog;" & vbCrLf & "GO" & vbCrLf s = s & "CREATE VIEW dbo.vCatalog AS SELECT p.Article, p.Photo AS [Фото], c.CategoryName AS [Категория товара], p.Name AS [Наименование товара], p.Description AS [Описание товара], m.ManufacturerName AS [Производитель], s.SupplierName AS [Поставщик], p.Price AS [Цена], u.UnitName AS [Единица измерения], p.Stock AS [Кол-во на складе], p.Discount AS [Действующая скидка] FROM dbo.Product p JOIN dbo.Category c ON p.CategoryId=c.CategoryId JOIN dbo.Manufacturer m ON p.ManufacturerId=m.ManufacturerId JOIN dbo.Supplier s ON p.SupplierId=s.SupplierId JOIN dbo.Unit u ON p.UnitId=u.UnitId;" & vbCrLf & "GO" & vbCrLf s = s & "IF OBJECT_ID('dbo.vOrders','V') IS NOT NULL DROP VIEW dbo.vOrders;" & vbCrLf & "GO" & vbCrLf s = s & "CREATE VIEW dbo.vOrders AS SELECT o.OrderId, STRING_AGG(oi.Article + N' x' + CAST(oi.Quantity AS nvarchar(10)), N', ') AS [Артикул заказа], st.StatusName AS [Статус заказа], (pp.PostalCode + ', г. ' + pp.City + ', ул. ' + pp.Street + ', д. ' + pp.House) AS [Адрес пункта выдачи], o.OrderDate AS [Дата заказа], o.DeliveryDate AS [Дата доставки] FROM dbo.[Order] o JOIN dbo.OrderStatus st ON o.StatusId=st.StatusId JOIN dbo.PickupPoint pp ON o.PickupPointId=pp.PickupPointId LEFT JOIN dbo.OrderItem oi ON oi.OrderId=o.OrderId GROUP BY o.OrderId, st.StatusName, pp.PostalCode, pp.City, pp.Street, pp.House, o.OrderDate, o.DeliveryDate;" & vbCrLf & "GO" & vbCrLf s = s & "IF OBJECT_ID('dbo.vw_UsersLogin','V') IS NOT NULL DROP VIEW dbo.vw_UsersLogin;" & vbCrLf & "GO" & vbCrLf s = s & "CREATE VIEW dbo.vw_UsersLogin AS SELECT u.UserId, u.FullName AS [ФИО], u.Login AS [Логин], u.Password AS [Пароль], r.RoleName AS [Роль] FROM dbo.[User] u JOIN dbo.Role r ON u.RoleId=r.RoleId;" & vbCrLf & "GO" & vbCrLf ViewsSql = s End Function Private Sub SeedSql() Dim wsP As Worksheet, wsU As Worksheet, wsO As Worksheet, wsK As Worksheet, ws As Worksheet For Each ws In ActiveWorkbook.Worksheets If HasHeader(ws, "Артикул заказа") Then Set wsO = ws ElseIf HasHeader(ws, "Логин") Then Set wsU = ws ElseIf HasHeader(ws, "Артикул") Then Set wsP = ws ElseIf Trim(CStr(ws.Cells(1, 1).Value)) <> "" Then Set wsK = ws End If Next ws ' справочники If Not wsU Is Nothing Then DictInsert wsU, "Роль сотрудника", "dbo.Role", "RoleName" If Not wsP Is Nothing Then DictInsert wsP, "Единица измерения", "dbo.Unit", "UnitName" DictInsert wsP, "Поставщик", "dbo.Supplier", "SupplierName" DictInsert wsP, "Производитель", "dbo.Manufacturer", "ManufacturerName" DictInsert wsP, "Категория товара", "dbo.Category", "CategoryName" End If If Not wsO Is Nothing Then DictInsert wsO, "Статус заказа", "dbo.OrderStatus", "StatusName" Emit "GO" If Not wsU Is Nothing Then SeedUsers wsU If Not wsK Is Nothing Then SeedPickups wsK If Not wsP Is Nothing Then SeedProducts wsP If Not wsO Is Nothing Then SeedOrders wsO Emit "GO" End Sub Private Sub DictInsert(ws As Worksheet, header As String, tbl As String, col As String) Dim c As Long, r As Long, lastR As Long, v As String c = ColIdx(ws, header): If c = 0 Then Exit Sub lastR = LastRow(ws) Dim d As Object: Set d = CreateObject("Scripting.Dictionary") For r = 2 To lastR v = Trim(CStr(ws.Cells(r, c).Value)) If Len(v) > 0 Then If Not d.Exists(v) Then d.Add v, 1 Next r Dim k As Variant For Each k In d.Keys Emit "INSERT INTO " & tbl & "(" & col & ") VALUES (N'" & Esc(CStr(k)) & "');" Next k End Sub Private Sub SeedUsers(ws As Worksheet) Dim r As Long, lastR As Long Dim cR As Long, cF As Long, cL As Long, cP As Long cR = ColIdx(ws, "Роль сотрудника"): cF = ColIdx(ws, "ФИО"): cL = ColIdx(ws, "Логин"): cP = ColIdx(ws, "Пароль") lastR = LastRow(ws) For r = 2 To lastR If Len(Trim(CStr(ws.Cells(r, cL).Value))) > 0 Then Emit "INSERT INTO dbo.[User](RoleId,FullName,Login,Password) VALUES (" & _ "(SELECT RoleId FROM dbo.Role WHERE RoleName=N'" & Esc(CStr(ws.Cells(r, cR).Value)) & "')," & _ "N'" & Esc(CStr(ws.Cells(r, cF).Value)) & "',N'" & Esc(CStr(ws.Cells(r, cL).Value)) & "',N'" & Esc(CStr(ws.Cells(r, cP).Value)) & "');" End If Next r End Sub Private Sub SeedPickups(ws As Worksheet) Dim r As Long, lastR As Long, id As Long, addr As String Dim p() As String, postal As String, city As String, street As String, house As String lastR = LastRow(ws) id = 0 For r = 1 To lastR ' у пунктов выдачи шапки нет — берём со строки 1 addr = Trim(CStr(ws.Cells(r, 1).Value)) If Len(addr) > 0 Then id = id + 1 p = Split(addr, ",") postal = "": city = "": street = "": house = "" If UBound(p) >= 0 Then postal = Trim(p(0)) If UBound(p) >= 1 Then city = Trim(Replace(p(1), "г.", "")) If UBound(p) >= 2 Then street = Trim(Replace(p(2), "ул.", "")) If UBound(p) >= 3 Then house = Trim(p(3)) Emit "INSERT INTO dbo.PickupPoint(PickupPointId,PostalCode,City,Street,House) VALUES (" & _ id & ",N'" & Esc(postal) & "',N'" & Esc(city) & "',N'" & Esc(street) & "',N'" & Esc(house) & "');" End If Next r End Sub Private Sub SeedProducts(ws As Worksheet) Dim r As Long, lastR As Long Dim cA, cN, cU, cPr, cS, cM, cC, cD, cQ, cDsc, cPh As Long cA = ColIdx(ws, "Артикул"): cN = ColIdx(ws, "Наименование товара"): cU = ColIdx(ws, "Единица измерения") cPr = ColIdx(ws, "Цена"): cS = ColIdx(ws, "Поставщик"): cM = ColIdx(ws, "Производитель") cC = ColIdx(ws, "Категория товара"): cD = ColIdx(ws, "Действующая скидка"): cQ = ColIdx(ws, "Кол-во на складе") cDsc = ColIdx(ws, "Описание товара"): cPh = ColIdx(ws, "Фото") lastR = LastRow(ws) For r = 2 To lastR If Len(Trim(CStr(ws.Cells(r, cA).Value))) > 0 Then Emit "INSERT INTO dbo.Product(Article,Name,UnitId,Price,SupplierId,ManufacturerId,CategoryId,Discount,Stock,Description,Photo) VALUES (" & _ "N'" & Esc(CStr(ws.Cells(r, cA).Value)) & "',N'" & Esc(CStr(ws.Cells(r, cN).Value)) & "'," & _ "(SELECT UnitId FROM dbo.Unit WHERE UnitName=N'" & Esc(CStr(ws.Cells(r, cU).Value)) & "')," & Num(ws.Cells(r, cPr).Value) & "," & _ "(SELECT SupplierId FROM dbo.Supplier WHERE SupplierName=N'" & Esc(CStr(ws.Cells(r, cS).Value)) & "')," & _ "(SELECT ManufacturerId FROM dbo.Manufacturer WHERE ManufacturerName=N'" & Esc(CStr(ws.Cells(r, cM).Value)) & "')," & _ "(SELECT CategoryId FROM dbo.Category WHERE CategoryName=N'" & Esc(CStr(ws.Cells(r, cC).Value)) & "')," & _ Num(ws.Cells(r, cD).Value) & "," & Num(ws.Cells(r, cQ).Value) & ",N'" & Esc(CStr(ws.Cells(r, cDsc).Value)) & "',N'" & Esc(CStr(ws.Cells(r, cPh).Value)) & "');" End If Next r End Sub Private Sub SeedOrders(ws As Worksheet) Dim r As Long, lastR As Long Dim cNum, cArt, cOd, cDd, cPk, cFio, cCode, cSt As Long cNum = ColIdx(ws, "Номер заказа"): cArt = ColIdx(ws, "Артикул заказа"): cOd = ColIdx(ws, "Дата заказа") cDd = ColIdx(ws, "Дата доставки"): cPk = ColIdx(ws, "Адрес пункта выдачи"): cFio = ColIdx(ws, "ФИО авторизированного клиента") cCode = ColIdx(ws, "Код для получения"): cSt = ColIdx(ws, "Статус заказа") lastR = LastRow(ws) For r = 2 To lastR Dim ordId As String: ordId = Trim(CStr(ws.Cells(r, cNum).Value)) If Len(ordId) > 0 Then Emit "INSERT INTO dbo.[Order](OrderId,OrderDate,DeliveryDate,PickupPointId,ClientUserId,ReceiveCode,StatusId) VALUES (" & _ ordId & "," & DateVal(ws.Cells(r, cOd).Value) & "," & DateVal(ws.Cells(r, cDd).Value) & "," & Num(ws.Cells(r, cPk).Value) & "," & _ "(SELECT TOP 1 u.UserId FROM dbo.[User] u JOIN dbo.Role rl ON u.RoleId=rl.RoleId WHERE u.FullName=N'" & Esc(CStr(ws.Cells(r, cFio).Value)) & "' ORDER BY CASE WHEN rl.RoleName=N'Авторизированный клиент' THEN 0 ELSE 1 END, u.UserId)," & _ Num(ws.Cells(r, cCode).Value) & ",(SELECT StatusId FROM dbo.OrderStatus WHERE StatusName=N'" & Esc(CStr(ws.Cells(r, cSt).Value)) & "'));" ' позиции: "ART, qty, ART, qty" Dim p() As String, i As Long, art As String, qty As String p = Split(CStr(ws.Cells(r, cArt).Value), ",") For i = 0 To UBound(p) - 1 Step 2 art = Trim(p(i)): qty = Trim(p(i + 1)) If Len(art) > 0 And IsNumeric(qty) Then Emit "INSERT INTO dbo.OrderItem(OrderId,Article,Quantity) VALUES (" & ordId & ",N'" & Esc(art) & "'," & qty & ");" End If Next i End If Next r End Sub Private Function ColIdx(ws As Worksheet, header As String) As Long Dim c As Long, lc As Long lc = LastCol(ws) For c = 1 To lc If Trim(CStr(ws.Cells(1, c).Value)) = header Then ColIdx = c: Exit Function Next c ColIdx = 0 End Function Private Function HasHeader(ws As Worksheet, header As String) As Boolean HasHeader = (ColIdx(ws, header) > 0) 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 Num(ByVal v As Variant) As String If Len(CStr(v)) = 0 Then Num = "0" Else Num = Replace(CStr(v), ",", ".") End Function Private Function DateVal(ByVal v As Variant) As String If VarType(v) = vbDate Then DateVal = "'" & Format$(v, "yyyy-mm-dd") & "'" Else DateVal = "NULL" 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