Translate

2014年8月20日 星期三

[VBA]Join two tables with any number of columns in a easy format

https://github.com/walter426/VbaUtilities/blob/master/SqlUtilities.bas
In order to join two tables into one, the SQL syntax is very complicated.
So I wrote below function to reduce the complexity.



''Create table which are joined from two tables
Public Function CreateTbl_JoinTwoTbl(Tbl_src_1_name As String, Tbl_src_2_name As String, JoinCond As String, ColSet_Join_1 As Variant, ColSet_Join_2 As Variant, Tbl_des_name As String, Optional ColSet_src_1 As Variant = Null, Optional ColSet_src_2 As Variant = Null, Optional ColSet_Order As Variant = Null) As String
    On Error GoTo Err_CreateTbl_JoinTwoTbl
    
    Dim FailedReason As String

    If TableExist(Tbl_src_1_name) = False Then
        FailedReason = Tbl_src_1_name & "does not exist!"
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If TableExist(Tbl_src_2_name) = False Then
        FailedReason = Tbl_src_2_name & "does not exist!"
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If IsNull(ColSet_Join_1) = True Then
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If IsNull(ColSet_Join_2) = True Then
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    

    DelTable (Tbl_des_name)
    
    
    Dim Col_Idx As Integer
    
    
    With CurrentDb
        If IsNull(ColSet_src_1) = True Then
            Dim RS_Tbl_src As Recordset
            Set RS_Tbl_src = .OpenRecordset(Tbl_src_1_name)
            
            Dim fld_idx As Integer
            Dim fld_name As String
            
            ColSet_src_1 = Array()
            
            With RS_Tbl_src
                For fld_idx = 0 To .Fields.count - 1
                    fld_name = .Fields(fld_idx).name
                    Call AppendArray(ColSet_src_1, Array("[" & fld_name & "]"))
                Next fld_idx
                
                .Close
                
            End With 'RS_Tbl_src
        End If


        If IsNull(ColSet_src_2) = True Then
            Set RS_Tbl_src = .OpenRecordset(Tbl_src_2_name)
            
            With RS_Tbl_src
                Dim NumOfColSet_Join_found As Integer
                NumOfColSet_Join_found = 0
                
                ColSet_src_2 = Array()
                    
                For fld_idx = 0 To .Fields.count - 1
                    fld_name = .Fields(fld_idx).name

                    If NumOfColSet_Join_found <= UBound(ColSet_Join_2) And FindStrInArray(ColSet_Join_2, fld_name) > -1 Then
                        NumOfColSet_Join_found = NumOfColSet_Join_found + 1
                    Else
                        Call AppendArray(ColSet_src_2, Array("[" & fld_name & "]"))
                    End If
                Next fld_idx
    
                .Close
                
            End With 'RS_Tbl_src
        End If
    End With 'CurrentDb
    

    Dim SQL_Seg_Select As String
    SQL_Seg_Select = "SELECT " & "[" & Tbl_src_1_name & "]." & Join(ColSet_src_1, ", [" & Tbl_src_1_name & "].") & ", " & "[" & Tbl_src_2_name & "]." & Join(ColSet_src_2, ", [" & Tbl_src_2_name & "].")

    Dim SQL_Seg_JoinOn As String
    SQL_Seg_JoinOn = "("

    For Col_Idx = LBound(ColSet_Join_1) To UBound(ColSet_Join_1)
        SQL_Seg_JoinOn = SQL_Seg_JoinOn & "[" & Tbl_src_1_name & "].[" & ColSet_Join_1(Col_Idx) & "] = [" & Tbl_src_2_name & "].[" & ColSet_Join_2(Col_Idx) & "] AND "
    Next Col_Idx

    SQL_Seg_JoinOn = Left(SQL_Seg_JoinOn, Len(SQL_Seg_JoinOn) - 4) & ")"

    
    Dim SQL_Seg_OrderBy As String
    SQL_Seg_OrderBy = ""
    
    If IsNull(ColSet_Order) = False Then
        SQL_Seg_OrderBy = "ORDER BY "
        
        For Col_Idx = LBound(ColSet_Order) To UBound(ColSet_Order)
            SQL_Seg_OrderBy = SQL_Seg_OrderBy & "[" & Tbl_src_1_name & "].[" & ColSet_Order(Col_Idx) & "], "
        Next Col_Idx
        
        SQL_Seg_OrderBy = Left(SQL_Seg_OrderBy, Len(SQL_Seg_OrderBy) - 2)
        
    End If
    
    
    Dim SQL_cmd As String
    
    SQL_cmd = SQL_Seg_Select & " " & vbCrLf & _
                "INTO [" & Tbl_des_name & "] " & vbCrLf & _
                "FROM [" & Tbl_src_1_name & "] " & JoinCond & " JOIN [" & Tbl_src_2_name & "] " & vbCrLf & _
                "ON " & SQL_Seg_JoinOn & vbCrLf & _
                SQL_Seg_OrderBy & " " & vbCrLf & _
                ";"

    RunSQL_CmdWithoutWarning (SQL_cmd)


Exit_CreateTbl_JoinTwoTbl:
    CreateTbl_JoinTwoTbl = FailedReason
    Exit Function

Err_CreateTbl_JoinTwoTbl:
    FailedReason = Err.Description
    Resume Exit_CreateTbl_JoinTwoTbl
    
End Function

2014年8月6日 星期三

[VBA] Transfer multiple objects(e.g. tables, queries) in a database

https://github.com/walter426/VbaUtilities

'Transfer multiple objects in a database
Public Function TransferObjSetInDb(TransferType As Variant, DatabaseType As String, DatabaseName As String, ObjectType As Variant, SrcList As Variant, DesList As Variant, Optional StructureOnly As Boolean = False, Optional StoreLogin As Boolean = False) As String
    On Error GoTo Err_TransferObjSetInDb

    Dim FailedReason As String

    If Len(Dir(DatabaseName)) = 0 Then
        FailedReason = DatabaseName
        GoTo Exit_TransferObjSetInDb
    End If
 

    If VarType(DesList) <> vbArray + vbVariant Then
        DesList = SrcList
    End If
 

    If UBound(SrcList) <> UBound(DesList) Then
        FailedReason = "No. of elements in SrcList and DesList are not equal"
        GoTo Exit_TransferObjSetInDb
    End If
 
 
    Dim TblNameIdx As Integer

    For TblNameIdx = 0 To UBound(SrcList)
        If ObjectType = acTable Then
            DelTable (DesList(TblNameIdx))
        ElseIf ObjectType = acQuery Then
            DelQuery (DesList(TblNameIdx))
        End If


        On Error Resume Next
        DoCmd.TransferDatabase TransferType, DatabaseType, DatabaseName, ObjectType, SrcList(TblNameIdx), DesList(TblNameIdx), StructureOnly, StoreLogin
        On Error GoTo Next_TblNameIdx
     
Next_TblNameIdx:
    Next TblNameIdx
 
    On Error GoTo Err_TransferObjSetInDb
 
 
Exit_TransferObjSetInDb:
    TransferObjSetInDb = FailedReason
    Exit Function

Err_TransferObjSetInDb:
    FailedReason = Err.Description
    Resume Exit_TransferObjSetInDb
 
End Function