Como crear macro para importar columnas de excel a DBF

Te pongo un enlace para convertirlo desde access

http://thundaxsoftware.blogspot.mx/2009/07/convertir-ficheros-excel-2007-dbase-dbf.html 

Encontré una macro para convertir los datos de la hoja de excel 2007 a dbf.

Como podrás observar, no es algo sencillo. Probé la macro para generar un archivo dbf, me parece que es para versión DBASE IV.

No tengo DBASE IV, por lo tanto no puedo abrir el archivo para revisarlo, pero te dejo el código para que lo pruebes.

Sub savedbf()
    Dim filename As Variant
    Dim temp As Variant
    Dim currentFile As String
    Dim defaultFile As String
    currentFile = ActiveWorkbook.Name
    temp = Split(currentFile, ".")
    temp(UBound(temp)) = "dbf"
    defaultFile = Join(temp, ".")
    If defaultFile = "dbf" Then
        defaultFile = ActiveWorkbook.Name & ".dbf"
    End If
    filename = Application.GetSaveAsFilename(InitialFileName:=defaultFile, FileFilter:="DBF 4 (dBASE IV) (*.dbf),*.dbf", Title:="Save As DBF")
    If filename = False Then Exit Sub
    Call DoSaveDefault(filename)
End Sub
Function DoSaveDefault(ByVal filename As String)
    ' Declare DB vars
    Dim path As Variant
    Dim file As Variant
    Dim tfile As Variant
    Dim table As Variant
    'Dim dbConn As ADODB.Connection
    ' Initialize DB vars
    path = Split(filename, "\")
    file = path(UBound(path))
    file = Replace(Left(file, Len(file) - 4), ".", "_") & Right(file, 4)
    tfile = "__T_DB__.dbf"
    path(UBound(path)) = ""
    path = Join(path, "\")
    table = Left(tfile, 8)
    filename = path & file
    ' Check if file exists
    On Error Resume Next
    GetAttr filename
    If Err.Number = 0 Then
        Dim mbResult As VbMsgBoxResult
        mbResult = MsgBox("The file " & file & " already exists. Do you want to replace the existing file?", _
            VbMsgBoxStyle.vbYesNo + VbMsgBoxStyle.vbExclamation, "File Exists")
        If mbResult = vbNo Then
            DoSaveDefault = False
            Exit Function
        Else
            SetAttr filename, vbNormal
            Kill filename
        End If
    End If
    Err.Number = 0
    GetAttr filename
    If Err.Number = 0 Then
        MsgBox "Unable to remove existing file " & file & ".", vbExclamation, "Error Removing File"
        DoSaveDefault = False
        Exit Function
    End If
    On Error GoTo 0
    ' Open DB connection
    'Set dbConn = New ADODB.Connection
    Set dbConn = CreateObject("adodb.connection")
    dbConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & path & ";Extended Properties=""DBASE IV;"";"
    ' Declare excel vars
    Dim dataRange As Range
    Set dataRange = Selection
    If dataRange.Areas.Count > 1 Then
        MsgBox "The command you chose cannot be performed with multiple selections. Select a single range and click the command again.", _
            VbMsgBoxStyle.vbCritical, "Error Saving File"
        DoSaveDefault = False
        Exit Function
    End If
    ' Expand selection if single cell (Expands selection using the Excel 2003 save DBF behavior)
    'If dataRange.Cells.Count = 1 Then
    '    If IsEmpty(dataRange.Cells(1).Value) Then
    '        MsgBox "The command could not be completed by using the range specified. Select a single cell within the range and try the command again.", _
    '            VbMsgBoxStyle.vbExclamation, "Error Saving File"
    '        DoSaveDefault = False
    '        Exit Function
    '    Else
    '        Set dataRange = dataRange.CurrentRegion
    '    End If
    'End If
    ' Expand selection if single cell (Differs from normal Excel 2003 behavior by not stopping at blank rows and columns)
    If dataRange.Cells.Count = 1 Then
        Dim row1 As Integer
        Dim rowN As Integer
        Dim col1 As Integer
        Dim colN As Integer
        Dim cellFirst As Range
        Dim cellLast As Range
        row1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlNext).row
        col1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
        rowN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
        colN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        Set cellFirst = ActiveSheet.Cells(row1, col1)
        Set cellLast = ActiveSheet.Cells(rowN, colN)
        Set dataRange = ActiveSheet.Range(cellFirst.Address, cellLast.Address)
    End If
    ' Declare data vars
    Dim i As Integer
    Dim j As Integer
    Dim numCols As Integer
    Dim numDataCols As Integer
    Dim numRows As Long
    Dim createString As String
    Dim fieldpos(), fieldvals(), fieldtypes(), fieldnames(), fieldactive()
    numCols = dataRange.Columns.Count
    numDataCols = 0
    numRows = dataRange.Rows.Count
    ReDim fieldtypes(0 To numCols - 1)
    ReDim fieldnames(0 To numCols - 1)
    ReDim fieldactive(0 To numCols - 1)
    ' Fill field names
    i = 0
    For Each c In dataRange.Rows(1).Columns
        ' Mark column active if not blank
        If WorksheetFunction.CountA(c.EntireColumn) > 0 Then
            fieldactive(i) = True
            numDataCols = numDataCols + 1
            If VarType(c.Value) = vbString Then
                fieldnames(i) = Left(Replace(c.Value, " ", "_"), 10)
            Else
                fieldnames(i) = "N" & c.Column
            End If
        Else
            fieldactive(i) = False
        End If
        i = i + 1
    Next
    ' Fill field positions
    ReDim fieldpos(0 To numDataCols - 1)
    ReDim fieldvals(0 To numDataCols - 1)
    For i = 0 To numDataCols - 1
        fieldpos(i) = i
    Next
    ' Fill field types
    If dataRange.Rows.Count < 2 Then
        For i = 0 To numCols - 1
            If fieldactive(i) Then
                fieldtypes(i) = vbString
            End If
        Next
    Else
        i = 0
        For Each c In dataRange.Rows(2).Columns
            If fieldactive(i) Then
                fieldtypes(i) = VarType(c.Value)
            End If
            i = i + 1
        Next
    End If
    ' Create table
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.table
    Dim col As ADOX.Column
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = dbConn
    Set tbl = New ADOX.table
    tbl.Name = table
    For i = 0 To numCols - 1
        ' Only add non-blank columns
        If fieldactive(i) Then
            Set col = New ADOX.Column
            col.Name = fieldnames(i)
            fillColumnType col, fieldtypes(i), dataRange.Columns(i + 1)
            tbl.Columns.Append col
            Set col = Nothing
        End If
    Next
    On Error Resume Next
    cat.Tables.Delete table
    On Error GoTo 0
    cat.Tables.Append tbl
    ' Populate table
    'Dim rs As ADODB.Recordset
    Dim r As Range
    Dim row As Long
    'Set rs = New ADODB.Recordset
    Set rs = CreateObject("adodb.recordset")
    rs.Open table, dbConn, adOpenDynamic, adLockPessimistic, adCmdTable
    If rs.LockType = LockTypeEnum.adLockReadOnly Then
        MsgBox "The recordset is read-only.", vbExclamation, "Error Inserting Record"
    End If
    For row = 2 To numRows
        Set r = dataRange.Rows(row)
        ' Only add non-blank rows
        If WorksheetFunction.CountA(r.EntireRow) > 0 Then
            i = 0
            j = 0
            For Each c In r.Cells
                If fieldactive(i) Then
                    fieldvals(j) = getValByVbType(c.Text, fieldtypes(i))
                    j = j + 1
                End If
                i = i + 1
            Next
            rs.AddNew fieldpos, fieldvals
        End If
    Next
    ' Close the recordset and connection
    Rs. Close
    DbConn. Close
    ' Copy file to final destination (this is necessary because the Jet driver limits
 ' the filename to 8 chars before the extension)
    'Dim fs As Scripting. FileSystemObject
    'Set fs = New Scripting.FileSystemObject
    'fs.CopyFile path & tfile, filename
    FileCopy path & tfile, filename
    'Set fs = Nothing
    Kill path & tfile
    DoSaveDefault = True
End Function
Function fillColumnType(col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean
    Select Case vtype
        Case vbInteger, vbLong, vbByte
            col.Type = adInteger
        Case vbSingle, vbDouble, vbDouble
            fillColNumberType col, colrange
        Case vbCurrency
            col.Type = adCurrency
        Case vbDate
            col.Type = adDate
        Case vbBoolean
            col.Type = adBoolean
        Case vbString
            fillColStringType col, colrange
        Case Else
            col.Type = adWChar
            col.Precision = 32
    End Select
    getAdoTypeFromVbType = True
End Function
Function getValByVbType(ByVal s As String, ByVal t As Integer)
    Dim result As Variant
    result = Null
    On Error Resume Next
    Select Case t
        Case vbInteger, vbLong, vbByte
            result = CInt(s)
        Case vbSingle, vbDouble, vbCurrency, vbDecimal
            If CInt(s) <> CDec(s) Then
                result = CDec(s)
            Else
                result = CInt(s)
            End If
        Case vbDate
            result = CDate(s)
        Case vbBoolean
            result = CInt(s) <> 0
        Case vbString
            result = s
        Case Else
            result = Null
    End Select
    On Error GoTo 0
    getValByVbType = result
End Function
Function fillColStringType(col As ADOX.Column, r As Range) As Boolean
    Dim lenshort As Integer
    Dim lenlong As Integer
    Dim l As Integer
    lenshort = Len(r.Cells(2).Text)
    lenlong = lenshort
    For Each c In r.Cells
        If c.row > 1 Then
            l = Len(c.Text)
            If l < lenshort Then
                lenshort = l
            End If
            If l > lenlong Then
                lenlong = l
            End If
        End If
    Next
    If lenlong > 254 Then
        col.Type = adLongVarWChar
    ElseIf lenlong > 128 And lenlong < 255 Then
        col.Type = adWChar
        col.Precision = 254
    ElseIf lenshort = lenlong And lenlong < 17 Then
        col.Type = adWChar
        col.Precision = lenlong
    Else
        col.Type = adWChar
        col.Precision = ceilPow2(lenlong)
    End If
    fillColStringType = True
End Function
Function fillColNumberType(col As ADOX.Column, r As Range) As Boolean
    Dim hasDecimal As Boolean
    Dim t As Boolean
    hasDecimal = False
    On Error Resume Next
    For Each c In r.Cells
        If c.row > 1 Then
            t = Val(c.Text) <> Int(Val(c.Text))
            If Err.Number = 0 And t Then
                hasDecimal = True
                Exit For
            End If
        End If
    Next
    On Error GoTo 0
    If hasDecimal Then
        col.Type = adNumeric
        col.Precision = 11
        col.NumericScale = 4
    Else
        col.Type = adInteger
    End If
    fillColNumberType = True
End Function
Function ceilPow2(x As Integer)
    Dim i As Integer
    i = 2
    Do While i < x
        i = i * 2
    Loop
    ceilPow2 = i
End Function

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )