none
CONEXION CON EXCEL PARA AGREGARLE DATOS RRS feed

  • Pregunta

  • Hola a todos.. tengo el siguiente codigo que es de visual basic para aplicaciones en especifico excel

    Private Sub btGenerar_Click()
    Dim strValidacion As String
    strValidacion = ""
    'iniciamos con las validacion de los datos a registrar
    If Range("b9").Text = "" Then strValidacion = strValidacion & " No se ha ingresado el nombre del cliente." & vbCrLf
    If Range("b11").Text = "" Then strValidacion = strValidacion & " No se ha ingresado la identificacion del cliente." & vbCrLf
    If txtFecha.Text = "" Then strValidacion = strValidacion & " No se ha ingresado la fecha de emision." & vbCrLf
    If cbSecuencial.ListIndex = -1 Then strValidacion = strValidacion & "No se ha seleccionado ningun secuencial de la factura." & vbCrLf
    If txtEstablecimiento.Text = "" Then strValidacion = strValidacion & "No se ha ingresado el numero de establecimiento." & vbCrLf
    If txtPtoEmi.Text = "" Then strValidacion = strValidacion & "No se ha ingresado el punto de emision." & vbCrLf
    If txtAutorizacion.Text = "" Then strValidacion = strValidacion & "No se ha ingresado el numero de autorizacion." & vbCrLf
    
    Dim bytTodoLleno As Byte
    bytTodoLleno = 0
    For fila = 13 To 35
        If Range("a" & fila).Value <> "" Then bytTodoLleno = bytTodoLleno + 1
        If Range("b" & fila).Value <> "" Then bytTodoLleno = bytTodoLleno + 1
        If Range("d" & fila).Value <> "" Then bytTodoLleno = bytTodoLleno + 1
        If Range("e" & fila).Value <> "" Then bytTodoLleno = bytTodoLleno + 1
        If Range("f" & fila).Value <> "" Then bytTodoLleno = bytTodoLleno + 1
    Next fila
    
    If bytTodoLleno = 0 Then
        strValidacion = strValidacion & "No se ha ingresado ningun producto para despachar." & vbCrLf
        ElseIf (bytTodoLleno) Mod 5 <> 0 Then
        strValidacion = strValidacion & "Los Datos del Producto no estan completos"
        btAgregar.Enabled = False
    End If
    
    'comprobamos si tenemos errores
    If strValidacion = "" Then
        'conectamos con el axuliar de ventas
        Dim sql, dir, extension As String
        Dim dblSubdif0, dblIvaCobrado, dblTotal, dblIva14, dblCompensado As String
        Dim dtFecha As Date
        Dim lngFecha As Long
    
        'como el separado decimal de el computador y el separador de valores sql es el mismo cambiamos a los valores el punto por la coma
        dblSubdif0 = Replace(Range("f36").Value, ",", ".")
        dblIvaCobrado = Replace(Range("f37").Value, ",", ".")
        dblIva14 = Replace(CStr(dblSubdif0 * 0.14), ",", ".")
        dblTotal = Replace(Range("f38").Value, ",", ".")
        dblCompensado = Replace(CStr(dblIva14 - dblIvaCobrado), ",", ".")
    
        'Excel representa las fechas como un numero por lo que realizamos tal conversion
        dtFecha = Format(txtFecha.Text, "DD/MM/YYYY")
        lngFecha = CLng(dtFecha)
    
        'colocamos la instruccion sql para ingresar los respectivos datos en el auxiliar de notas de entrega
        sql = "INSERT INTO [NOTENTREGA$] (FECHA, AUTORIZACIÓN, ESTABL, PTOEMI, SEC, IDCLIENTE, DENOCLIENTE, SUBDIF0, IVACOBRADO, TOTAL, IVA14, COMPENSADO, DESCRIPCION) VALUES (" & lngFecha & ", " & txtAutorizacion.Text & ", " & txtEstablecimiento.Text & ", " & txtPtoEmi.Text & ", " & cbSecuencial.Text & ", '" & Range("b11").Value & "', '" & Range("b9").Value & "', " & dblSubdif0 & ", " & dblIvaCobrado & ", " & dblTotal & ", " & dblIva14 & "," & dblCompensado & ", '0')"
        Call GuardarDatos(sql, ThisWorkbook.Path & "\AUXILIARES.XLSX")
    
    
        'colocamos la instruccion sql para ingresar los respectivos productos en la salida del inventario
        For intFilaProd = 13 To 35
            If Range("b" & intFilaProd).Value <> "" Then
            
                'colocammos los datos en variables para facilitar su relacion y asignacion de valores a la instruccion sql
                Dim strCeros, strCodProducto, strDenoProducto As String
                Dim dtFechaDoc As Date
                Dim lngFechaDoc As Long
                Dim strNroDoc As String
                Dim strCantProd, strVUnitInv, strvTotInv, strVUnitFact, strVTotFact, UtilidadPorc As String
                strCodProducto = CStr(Range("b" & intFilaProd).Value)
                strDenoProducto = CStr(Range("d" & intFilaProd).Value)
                dtFechaDoc = Format(txtFecha.Text, "dd/mm/yyyy")
                lngFechaDoc = CLng(dtFechaDoc)
    
                'para rellenar el campo numero de documento en inventario debemos colocar el establecimiento, ptoemision  secuencial unidos
                strCeros = "000"
                strNroDoc = Mid(strCeros, 1, 3 - Len(txtEstablecimiento.Text)) & txtEstablecimiento.Text & "-"
                strNroDoc = strNroDoc & Mid(strCeros, 1, 3 - Len(txtPtoEmi.Text)) & txtPtoEmi.Text & "-"
                strCeros = "000000000"
                strNroDoc = strNroDoc & Mid(strCeros, 1, 9 - Len(cbSecuencial.Text)) & cbSecuencial.Text
                strCantProd = Replace(Range("a" & intFilaProd).Value, ",", ".")
                
                'conectamos con la base de datos del inventario para obtener y calcular el valor de cada producto
                Dim rsValProductos As ADODB.Recordset
                Dim conProductos As ADODB.Connection
                Set conProductos = f_ConectarALibroExcel(ThisWorkbook.Path & "\INVENTARIO.xlsm", True)
    
                Set rsValProductos = f_RsHojaExcel(conProductos, "ENTRADAS")
    
                'tomamos el valor total y las cantidades de las entradas
                Dim dblValInv, dblCantInv  As Double
                dblValInv = 0
                dblCantInv = 0
                Dim intEsta As Integer
                intEsta = 0
                    While Not rsValProductos.EOF
                        If rsValProductos.Fields(0).Value = strCodProducto Then
                        dblValInv = dblValInv + CDbl(rsValProductos.Fields(6).Value)
                        dblCantInv = dblCantInv + CDbl(rsValProductos.Fields(4).Value)
                        End If
                    rsValProductos.MoveNext
                    Wend
                   Set rsValProductos = Nothing
                
                Set rsValProductos = f_RsHojaExcel(conProductos, "SALIDAS")
    
                'tomamos el valor total y las cantidades de las entradas
                     While Not rsValProductos.EOF
                        If rsValProductos.Fields(0).Value = strCodProducto Then
                        dblValInv = dblValInv - CDbl(rsValProductos.Fields(6).Value)
                        dblCantInv = dblCantInv - CDbl(rsValProductos.Fields(4).Value)
                        End If
                    rsValProductos.MoveNext
                    Wend
                rsValProductos.Close
                conProductos.Close
                Set conProductos = Nothing
                Set rsValProductos = Nothing
                strVUnitInv = Replace(CStr(Round(dblCantInv / dblValInv, 3)), ",", ".")
                strvTotInv = Replace(CStr(strCantProd * (Round(dblCantInv / dblValInv, 3))), ",", ".")
                strVUnitFact = Replace(CStr(Range("e" & intFilaProd).Value), ",", ".")
                strVTotFact = Replace(CStr(Range("f" & intFilaProd).Value), ",", ".")
                
                UtilidadPorc = Replace(CStr(CDbl(strVTotFact) - CDbl(strvTotInv)), ",", ".")
                UtilidadPorc = Replace(CStr((CDbl(strvTotInv) / UtilidadPorc)), ",", ".")
                
                sql = "INSERT INTO [SALIDAS$] (CodProducto, DenoProducto, FechaDoc, NroDoc, CantProd, VUnitInv, vTotInv, VUnitFact, VTotFact, UtilidadPorc) VALUES ('" & strCodProducto & "', '" & strDenoProducto & "', " & lngFechaDoc & ", '" & strNroDoc & ", '" & strCantProd & ", " & strVUnitInv & ", " & strvTotInv & ", " & strVUnitFact & ", " & strVTotFact & ", " & strUtilidadPorc & ")"
            Call GuardarDatos(sql, ThisWorkbook.Path & "\INVENTARIO.XSLM")
            End If
        Next intFilaProd
    MsgBox ("nota de entrega generada correctamente")
    
    Else
    'en caso de error mostramos un mensaje critico
    Dim errores
    errores = MsgBox(strValidacion, vbCritical, "ERROR")
    End If

    pero me he matodo buscando porque razon me da el error de "NO SE PUEDE ACTUALIZAR. BASE DE DATOS U OBJETO DE SOLO LECTURA" trato de una vez calculado el valor promedio de un producto me inserte este dato en la hoja "salida" que es donde llevo el reregistro de inventario para hacer esto he creado la siguientes funciones:

    Dim PRODUCTOS As ADODB.Recordset
    Dim rsNotEntrega As ADODB.Recordset
        Dim ado_Conexion As ADODB.Connection
        
        
    'Esta es la versión que pasa el proveedor en la propia cadena de conexión
    Function f_ConectarALibroExcel(ByVal str_Libro As String, ByVal bol_2007 As Boolean) 'As ADODB.Connection
        
        Dim str_Conexion As String
    
        
        'Establecemos el proveedor y la versión
        If bol_2007 Then
    
             str_Conexion = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                           "Extended Properties=Excel 12.0;"
    
        Else
    
            
            str_Conexion = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                           "Extended Properties=Excel 8.0;"
    
        End If
    
         'Establecemos la cadena de conexión
        str_Conexion = str_Conexion & _
                       "Data Source=" & str_Libro
        
        'Creamos el objeto conexión
        Set ado_Conexion = CreateObject("ADODB.Connection")
        
        'Conectamos el objeto al libro Excel
        ado_Conexion.Open str_Conexion
        
        'La función devuelve el objeto conexión
        Set f_ConectarALibroExcel = ado_Conexion
        
        'Vaciamos el objeto
    
        Set ado_Conexion = Nothing
        
    End Function 'f_ConectarALibroExcel
       
    
    Function f_RsHojaExcel(ado_Conexion, str_Hoja) 'As ADODB.Recordset
    
        Dim str_Consulta As String
        Dim rs_Consulta As ADODB.Recordset
    
        'Montamos la consulta, agregando un dolar al final del nombre
        'de la hoja y encerrando el resultado entre corchetes
        str_Consulta = _
            "SELECT " & vbCrLf & _
            "       * " & vbCrLf & _
            "FROM " & vbCrLf & _
            "       [" & str_Hoja & "$]"
    
        'Creamos el Recordset
        Set rs_Consulta = CreateObject("ADODB.Recordset")
    
        'Ejecutamos la consulta
        rs_Consulta.Open str_Consulta, ado_Conexion
    
        'La función devuelve el Recordset
        Set f_RsHojaExcel = rs_Consulta
    
        'Vaciamos el objeto
        Set rs_Consulta = Nothing
    
    End Function 'f_RsHojaExcel
    
    Function GuardarDatos(ByVal str_Consulta As String, ByVal str_UrlBasedatos As String)
    
    'Definición del objeto de conexión
    Dim ado_Conexion2 As ADODB.Connection
    
    'Variable para la instrucción INSERT str_Consulta
    
    'Creamos un objeto y lo conectamos al libro
    Set ado_Conexion2 = CreateObject("ADODB.Connection")
    ado_Conexion2.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & str_UrlBasedatos & "; Extended Properties=Excel 12.0"
    
    
    
    'Ejecutamos la instrucción INSERT
    ado_Conexion2.Execute str_Consulta
    
    'Cerramos la conexión y vaciamos el objeto
    ado_Conexion2.Close
    Set ado_Conexion2 = Nothing
    End Function
    Function decimales(valor As String) As Boolean
            Dim X As Integer, contador As Integer, z As Integer
            Dim sdec As String
            sdec = Application.DecimalSeparator
            decimales = False
            contador = 0
            For X = 1 To Len(valor)
                If Mid(valor, X, 1) = sdec Then
                    For z = X + 1 To Len(valor)
                        contador = contador + 1
                    Next z
                End If
            Next X
            If contador >= 2 Then decimales = True
        End Function
        Function SINMASESPACIOS(texto As String) As String
            For a = 1 To Len(texto)
                While Mid(texto, a, 2) = "  "
                    texto = Replace(texto, "  ", " ")
                Wend
            Next a
            While InStr(1, texto, " ") = 1
                texto = Replace(texto, " ", "", 1, 1)
            Wend
            For b = 1 To Len(texto)
                While Mid(texto, Len(texto), 1) = " "
    
                    texto = Mid(texto, 1, Len(texto) - 1)
                Wend
            Next b
            SINMASESPACIOS = texto
        End Function
        
    Function separadorDecimal(numero As String) As Boolean
    Dim sdec  As String
    Dim contador As Integer
    contador = 0
    sdec = Application.DecimalSeparator
    For a = 1 To Len(numero)
    If Mid(numero, a, 1) = sdec Then contador = contador + 1
    Next
    If contador > 0 Then separadorDecimal = True Else separadorDecimal = False
    End Function
    

    todo esto esta dentro de un modulo.. y llevo dias buscando el problema espero me puedan ayudar

    martes, 4 de julio de 2017 3:29

Todas las respuestas