MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Várias sheets renomeando e definindo range

    Compartilhe
    avatar
    janettepires
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 105
    Registrado : 14/03/2013

    [Resolvido]Várias sheets renomeando e definindo range

    Mensagem  janettepires em Ter 09 Maio 2017, 14:07

    BOM DIA!

    Preciso importar todos os sheets de uma planilha como tabelas no Access, teria como renomear as tabelas enquanto importa e definir o range?

    Vi esse código do JP, mas não atende, pois em determinadas sheets ele não interpreta alguns dados e trava.


    Private Sub SeuBotao_Click()
    Dim appExcel As Excel.Application
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Dim strValue As String
    Set appExcel = CreateObject("Excel.Application")
    Set wb = appExcel.Workbooks.Open("C:\temp.xls") 'nome do seu excel e seu diretorio
    For Each sh In wb.Sheets
    Debug.Print sh.Name
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "tbl_" & sh.Name, "C:\temp.xls", True, sh.Name & "!"
    Next
    wb.Close
    appExcel.Quit
    On Error GoTo 0
    Exit Sub
    End Sub
    avatar
    JPaulo
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 9703
    Registrado : 04/11/2009

    Re: [Resolvido]Várias sheets renomeando e definindo range

    Mensagem  JPaulo em Ter 09 Maio 2017, 14:32

    Veja outros, no link da minha assinatura 102 códigos VBA gratuitos,

    Código = ImportarExcelParaAccess


    .................................................................................
    Contribua com o maximoaccess nos links abaixo, ajude a melhorar este que é o seu site na NET.

    [Você precisa estar registrado e conectado para ver este link.]
    [Você precisa estar registrado e conectado para ver este link.]

    Sucesso e Bons Estudos
    Success and Good Studies

    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]
    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]
    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]
    avatar
    janettepires
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 105
    Registrado : 14/03/2013

    Re: [Resolvido]Várias sheets renomeando e definindo range

    Mensagem  janettepires em Ter 09 Maio 2017, 16:28

    Encontrei uma função que faz exatamente o que eu preciso.

    Public Function ImportaDados(Path As String)


    On Error GoTo Err_handler

    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook


    'Set ww = xlWb.Sheets.Item(Z)
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Open(Path)


    For Each ws In xlWb.Worksheets
    For I = 1 To 300 'Linha Inicial e Final
    If ws.Range("A" & I).Value > 0 Then

    strSQL = "Insert Into TabelaDados (Campo1,Campo2,Campo3,Campo4,Campo5,Campo6,Campo7,Campo8,Campo9,Campo10,Campo11,Campo12,campo13)"
    strSQL = strSQL & " Values ('" & ws.Range("A" & I).Value & "','" & ws.Range("B" & I).Value & "','" & ws.Range("C" & I).Value & "','" & ws.Range("D" & I).Value & "','" & ws.Range("E" & I).Value & "','" & ws.Range("F" & I).Value & "','" & ws.Range("G" & I).Value & "','" & ws.Range("H" & I).Value & "','" & ws.Range("I" & I).Value & "','" & ws.Range("J" & I).Value & "','" & ws.Range("K" & I).Value & "','" & ws.Range("L" & I).Value & "','" & ws.Range("M" & I).Value & ws.Name & " ')"
    ' strSQL = strSQL & " Names ('" & ws.Range("M" & I).Name & "')"

    'ws.Range("M" & I).Value = ws.Name

    DoCmd.SetWarnings False
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True

    Else
    Exit For
    End If
    Next



    'MsgBox "Importada Planilha: " & ws.Name

    Next ws


    MsgBox "Dados importados com sucesso.", vbInformation, "Mensagem"


    xlApp.Close
    ws.Close

    'Set xlApp = Nothing
    Set xlWb = Nothing

    Exit Function

    Err_handler:
    If Err.Number > 0 Then
    MsgBox "Ocorreu um erro. Detalhes do erro: " & vbCrLf & vbCrLf & Err.Description, vbCritical, "Mensagem"
    Err.Clear
    Exit Function
    End If
    End Function

      Data/hora atual: Ter 21 Nov 2017, 10:14