Attribute VB_Name = "udf_joinSql"
'-------------------------------------------------------------------------------
'File         : udf_joinSql.bas
'Environment  : Excel VBA 2010 +
'Version      : 1.0.0
'Name         : joinSql
'Author       : C754943 Stefan Erb (ERS)
'History      : 03.08.2016 - ERS - Creation
'-------------------------------------------------------------------------------
Option Explicit

'------------------------------------
'--- Settings
'------------------------------------
'SQL-FORMATE:
    'Datumsformat
    'Oracle: TO_DATE('08/13/2017', 'MM/DD/YYYY')
    Private Const C_DATE_FORMAT = "TO_\DATE('MM\/DD\/YYYY', '\M\M\/\D\D\/\Y\Y\Y\Y')"
    Private Const C_DATE_TIMESTAMP = "sysdate"

    'MS Acceess: #08/13/2017'
    'Private Const C_DATE_FORMAT = "\#MM\/DD\/YYYY\#"
    'Private Const C_DATE_TIMESTAMP = "now"

    Private Const C_DATA_QUOTE = "'"
    Private Const C_DELEMITER = ", "

'Datentypen Kurzzeichen
    'Formate für den Formatrange
    'Standard, falls nichts angegeben wird: T_NUMBER
    Private Const T_STRING = "s"           'String      text -> 'text'
    Private Const T_DATE = "d"             'Datum       1.2.2016 -> TO_DATE('02/01/2016', 'MM/DD/YYYY')
    Private Const T_SUPRESS = "x"          'Spalte unterdrücken
    Private Const T_DEFAULT = ""           'Wert unverändert zurückgeben

    Private Const A_NULL = "n"              'Standard:  NULL
    Private Const A_EMPTY = "e"             'Empty:     ''
    Private Const A_0 = "0"                 'Null:      0
    Private Const A_TIMESTAMP = "t"         '           SYSDATE

'------------------------------------
'--- Infos
'------------------------------------

' - Wenn die Spalte keinen Eintrag im HeaderRange hat, wird sie unterdrück
' - Spalten, welche im TypeRange 'x' drin haben, werden ebenfalls unterdrückt
' - Die Attribute zur Nullregelung können dem Type angehängt werden
'   zB: sn -> Feld ist ein String, wenn kein Wert vorhanden ist wird der Text NULL ausgegeben
'       se -> Wieder ein String. Aber der Leerwert wird als '' ausgegeben
'       s  -> Wie sn
'       0  -> ohne formatierung. Ein Leerwertr wird als 0 ausgegeben
'       etc.

'------------------------------------
'--- Public Methodes
'------------------------------------

'/**
' * Setz ein einfaches Insert zusammen
' * @example    =joinSql("MY_TABLE"; A$9:Q$9; A11:Q11; A$10:Q$10)
' *
' * @param  Cell/String     Name der Zieltabelle
' * @param  Range           Range mit den Spaltennamen
' * @param  Range           Range mit den Daten (eine Zeile)
' * @param  Range           Range mit den Datentypzuweisung. Die Typenzuweisung ist typ & attribut.
' * @param  String          Datumsformat für den SQL-String
' * @return String
' */
Public Function joinSql( _
        ByVal iTableName As String, _
        ByRef iHeaderRange As Range, _
        ByRef iDataRange As Range, _
        Optional ByRef iTypeRange As Range _
) As String
    Dim cols() As String, values() As String, types() As String
    Dim size As Long, i As Long, k As Long, delta As Long
    Dim typ As String, attr As String

    'Anzahl Spalten ermitteln und arrays dimensionieren
    size = iHeaderRange.Cells.Count - 1

    'Spaltennamen ermitteln
    cols = range2array(iHeaderRange, size)

    'Falls ein Typenrange exisitiert, die Typen auslesen
    If Not IsMissing(iTypeRange) Then
        types = range2array(iTypeRange, size)
    Else
        ReDim types(size)
    End If

    'Daten auslesen
    values = range2array(iDataRange, size)

    'Daten formatieren
    For i = size To 0 Step -1
        splitType types(i), typ, attr

        'Falls kein Spaltennamen vorhanden ist, die Spalte unterdrücken
        If cols(i) = Empty Then typ = T_SUPRESS

        'Leerer Wert abhandeln
        If values(i) = Empty And Not typ = T_SUPRESS Then
            typ = T_DEFAULT
            Select Case attr
                Case A_0:           values(i) = "0"
                Case A_EMPTY:       typ = T_STRING
                Case A_TIMESTAMP:   values(i) = C_DATE_TIMESTAMP
                Case Else:          values(i) = "NULL"
            End Select
        End If

        'Typ auswertwen
        Select Case typ
            Case T_STRING:          values(i) = C_DATA_QUOTE & values(i) & C_DATA_QUOTE
            Case T_DATE:            values(i) = Format(values(i), C_DATE_FORMAT)
            Case T_SUPRESS:
                delta = delta + 1
                'Alle Inhalte eins vorschieben
                For k = i To size - delta
                    cols(k) = cols(k + 1)
                    values(k) = values(k + 1)
                Next k
            Case Else:              'Ansonsten value unverändert stehen lassen
        End Select
    Next i

    'Leere Spalten am Ende, die durch supress entstanden sind, entfernen
    ReDim Preserve cols(size - delta)
    ReDim Preserve values(size - delta)

    joinSql = "insert into " & iTableName & " (" & join(cols, C_DELEMITER) & ") values (" & join(values, C_DELEMITER) & ");"
End Function

'/**
' * Gibt die Werte eines Ranges als Array zurück
' * @param  Range
' * @param  Long        Grösse des Arrays. Bei -1 wird der Array der Rangegrösse angepasst
' * @return Array<String>
' */
Private Function range2array(ByRef iRange As Range, Optional ByVal iSize As Long = -1) As String()
    Dim i As Long
    Dim retArr() As String

    'Array auf Rangegrösse definieren
    ReDim retArr(iRange.Count - 1)
    'Alle Elemente des Ranges in den Array abfüllen
    For i = 0 To iRange.Count - 1
        retArr(i) = iRange.item(i + 1).Text
    Next i
    'Auf gewünschte Grösse kürzen/verlängern
    ReDim Preserve retArr(IIf(iSize = -1, iRange.Count - 1, iSize))

    range2array = retArr
End Function

'/**
' * Teilt den Inhalt einer Typenzelle auf Typ und Attribut auf
' * @param  String  Type-String
' * @param  String  Out/ Typ
' * @param  String  Out/ Attribut
' * @return Boolean Typen-String konnte aufgeteilt werden
' */
Private Function splitType(ByVal iString As String, Optional ByRef oType As String, Optional ByRef oAttr As String) As Boolean
    '/^([sdx]?)([ne0t]?)$/i
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^([" & T_DATE & T_DEFAULT & T_STRING & T_SUPRESS & "]?)([" & A_EMPTY & A_NULL & A_0 & A_TIMESTAMP & "]?)$/i")
    splitType = rx.test(iString)
    If splitType Then
        Dim m As Object: Set m = rx.execute(iString)(0)
        oType = m.subMatches(0)
        oAttr = m.subMatches(1)
    End If
End Function


'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode), m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function