[Resolvido]Várias sheets renomeando e definindo range

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

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

Código = ImportarExcelParaAccess

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