' Importante: para este projeto deixe habilitado em ferramentas eferencias
'Visual Basic for Applications
'Microsoft Excel 11.0 Object Library
'Microsoft Forms 2.0 Object Library
'Microsoft ADO Ext. 2.6 for DDL and Security
'Microsoft ActiveX Data Objects 2.6 Library


Public vdiretorio As String
Public varq_mdb As String
Public vtabela As String
Public verro As Double
Public vDisplay_em_tela As Double
Public vNome_Aba_Mobile_original As String

Public conn As ADODB.Connection
Public rs As ADODB.Recordset

Public vVetor_campos As Double
Dim Mycampos() As campos
Private Type campos
    campo As String
    tipo    As String
    tamanho As Double
    numero_coluna As Double
End Type


Private Sub Cmd_Iniciar_Click()
Dim varq As String

Application.StatusBar = "Buscando configurações"
DoEvents

x = buscar_configuracoes

varq = descobrir_arquivo_para_configuracoes

vresp = carregar_configuracoes(varq)

If verro = 0 Then
    Application.StatusBar = "Criando banco de dados"
    DoEvents

    x = criar_banco
    
    x = ler_diretorio
    
    Application.StatusBar = ""
    DoEvents
    
    MsgBox "Fim"
Else
    Application.StatusBar = ""
    DoEvents

    MsgBox "Nada foi executado"
End If


End Sub



Private Function buscar_configuracoes()

vNome_Aba_Mobile_original = "carregar"
vdiretorio = Sheets(vNome_Aba_Mobile_original).Range("c7").Value
varq_mdb = Sheets(vNome_Aba_Mobile_original).Range("c3").Value
vtabela = Sheets(vNome_Aba_Mobile_original).Range("c5").Value
verro = 0
vDisplay_em_tela = 100

Fechar_Todos_Arqs_Excel

End Function
Private Sub Fechar_Todos_Arqs_Excel()

'fechar todas as planilhas abertas
For Each w In Workbooks
    
    vTamanho = Len(vNome_Aba_Mobile_original)
    If UCase(Mid(UCase(w.Name), 1, vTamanho)) = Mid(UCase(vNome_Aba_Mobile_original), 1, vTamanho) Then
        vnome = w.Name
    Else
        vnome = w.Name
        Windows(vnome).Close
    End If
Next
End Sub


Private Function descobrir_arquivo_para_configuracoes()
Dim vNome_Arq_Completo As String
Dim fs, f, f1, fc, s, vez

vresp = ""

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(vdiretorio + "\")
Set fc = f.Files
 
 
For Each f1 In fc
    varquivo = f1.Name
    vNome_Arq_Completo = vdiretorio + "\" + f1.Name
    
    If InStr(UCase(f1.Name), ".XLS") > 0 Then
        vresp = vNome_Arq_Completo
        Exit For
    End If
Next
descobrir_arquivo_para_configuracoes = vresp
End Function

Private Function carregar_configuracoes(vNome_Arq_Completo As String)

Workbooks.Open vNome_Arq_Completo

For Each w In Workbooks(2).Worksheets
    vnome_aba = UCase(w.Name)
    Sheets(vnome_aba).Select
    Exit For
Next

vqtde = Application.WorksheetFunction.CountA(Sheets(vnome_aba).Rows(1))

Sheets(vnome_aba).Select
Sheets(vnome_aba).Cells.Select
Sheets(vnome_aba).Cells.EntireColumn.AutoFit
Sheets(vnome_aba).Range("A1").Select


vVetor_campos = 0
For i = 1 To vqtde + 200

    vconteudo = Sheets(vnome_aba).Cells(2, i).Value

    Sheets(vnome_aba).Cells(1, i).Select
    With Selection
        vnome = .Value2
        vtipo = .Formula
        vTamanho = Int(.ColumnWidth) + 1
        vnumero_coluna = i
    End With
    
    If Len(Trim(vnome)) > 0 Then
        vtipo = "T"
        If Len(Trim(vconteudo)) > 0 Then
            If IsNumeric(vconteudo) Then
                vtipo = "N"
            End If
    
            If IsDate(vconteudo) Then
                vtipo = "D"
            End If
        End If
 
        vnome = Replace(vnome, " ", "_")
 
        For t = 0 To vVetor_campos - 1
            If Mycampos(t).campo = vnome Then
                MsgBox "Título de campos repetidos. Veja a primeira linha da aba " + vnome_aba + " - Campo " + vnome
                verro = 1
                Exit For
            End If
        Next
    
        If verro = 1 Then
            Exit For
        End If
        
        ReDim Preserve Mycampos(vVetor_campos)
        Mycampos(vVetor_campos).campo = vnome
        Mycampos(vVetor_campos).tipo = vtipo
        Mycampos(vVetor_campos).tamanho = vTamanho
        Mycampos(vVetor_campos).numero_coluna = vnumero_coluna
        vVetor_campos = vVetor_campos + 1
    End If

Next

 
Workbooks(2).Activate
Workbooks(2).Close False

End Function




Private Function criar_banco()
Dim catalogo As ADOX.Catalog
Dim tbl As ADOX.Table

 
' Exclui o banco de dados se ele ja existir
On Error Resume Next
Kill varq_mdb
 

' Criando um banco de dados
Set catalogo = New ADOX.Catalog
catalogo.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & varq_mdb & ";"

' Criando uma nova tabela
Set tbl = New ADOX.Table
' tbl.Name = vtabela


With tbl
    .Name = vtabela
       
    For i = 0 To vVetor_campos - 1
    
        vcampo = Mycampos(i).campo
        vtipo = Mycampos(i).tipo
        vTamanho = Mycampos(i).tamanho
 
        If vtipo = "D" Then
            tbl.Columns.Append vcampo, adDate
        
        ElseIf vtipo = "N" Then
            tbl.Columns.Append vcampo, adDouble
    
        Else
            tbl.Columns.Append vcampo, adVarWChar, 255
        End If
        
        tbl.Columns.Item(vcampo).Attributes = adColNullable

    Next
End With

catalogo.Tables.Append tbl

'conn.Execute "INSERT INTO TabelaTeste (Nome) VALUES ('Macoratti')"
 
Set conn = Nothing
Set tbl = Nothing
Set catalogo = Nothing

End Function


Private Function ler_diretorio()
Dim vNome_Arq_Completo As String
Dim fs, f, f1, fc, s, vez

Set rs = New ADODB.Recordset
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + varq_mdb


vresp = ""

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(vdiretorio + "\")
Set fc = f.Files
 
 
For Each f1 In fc
    varquivo = f1.Name
    vNome_Arq_Completo = vdiretorio + "\" + f1.Name
    
    If InStr(UCase(f1.Name), ".XLS") > 0 Then
        x = carregar_dados(vNome_Arq_Completo)
    End If
Next

conn.Close

End Function

Private Function carregar_dados(vNome_Arq_Completo As String)

rs.Open "Select * from   " + vtabela, conn, 1, 3

Workbooks.Open vNome_Arq_Completo

Workbooks(2).Activate

For Each w In Workbooks(2).Worksheets
    vnome_aba = UCase(w.Name)
    Sheets(vnome_aba).Select
    
    Sheets(vnome_aba).Range("A1").Select
    Sheets(vnome_aba).Range(Selection, Selection.End(xlDown)).Select
    vlinha_final = Sheets(vnome_aba).Range(Selection, Selection.End(xlDown)).Count

    vcontador = 0
    For i = 2 To vlinha_final
    
        vcontador = vcontador + 1
        If vcontador Mod vDisplay_em_tela = 0 Then
            Application.StatusBar = "Lendo " + vnome_aba + " - Linha " + CStr(i)
            DoEvents
        End If
    
        vadd = 0
        For j = 0 To vVetor_campos - 1
         
            vnumero_coluna = Mycampos(j).numero_coluna
            vaux = Trim(Sheets(vnome_aba).Cells(i, vnumero_coluna))
            If Len(vaux) > 0 Then
                
                If vadd = 0 Then
                    rs.AddNew
                    vadd = 1
                End If
                        
                rs.Fields(Mycampos(j).campo) = Sheets(vnome_aba).Cells(i, vnumero_coluna)
            End If
            
        Next
        If vadd = 1 Then
            rs.Update
        End If
    Next
Next
rs.Close

Workbooks(2).Activate
Workbooks(2).Close False

End Function