Para quem estiver começando, fiz um pequeno programa para carregar um arquivo excel para um banco de dados access. Neste projeto, você irá aprender a criar uma tabela e carregar dados e a partir dai utilizando a sua imaginação, poderá criar novos recursos para o seu dia a dia.
' 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
