none
Aplicar Formato Personalizado a Celdas desde VBA RRS feed

  • Pregunta

  • Buen día:

    Poseo una pequeña aplicacion en Access en la cual capturo novedades de nomina de empleados. En dicha aplicación he insertado un modulo de codigo VBA el cual me permite realizar una exportacion de registros desde Access hacia un archivo de Excel ingresados en un intervalo de fechas que la aplicacion solicita ingresar al momento de efectuar la exportacion.

    Este codigo funciona perfectamente, pero resulta que debo aplicar cierto formato a cada celda en Excel, ya que el archivo final se convierte en un archivo plano para ser subido al programa contable.

    Requiero de su amable colaboración para que me digan como puedo aplicar el formato que necesito en el archivo Excel así:

    Ejemplo: En la celda A2 el valor traido de Access es 72048768. Necesito aplicar un formato de tal forma que me quede 0000072048768. Es decir, en la columna A los valores introducidos en cada celda deben completar 13 digitos (completando con ceros adicionales a la izquierda), en la columna B se deben completar 5 digitos, en la columna C se deben completar con 3 digitos y asi sucecivamente para cada columna subsiguiente

    A continuacion el codigo VBA que realiza el copiado de los datos extraidos de Aceess en la hoja de Excel

    fila = 2
    columna = 1
    While Not rst.EOF
    For Each fld In rst.Fields
    .Cells(fila, columna) = fld.Value
    If columna = 1 then
    AQUI ES DONDE DEBO APLICAR EL FORMATO A LA CELDA
    End If
    columna = columna + 1
    Next
    columna = 1
    fila = fila + 1
    rst.MoveNext
    Wend

    Sin embargo, en el codigo anterior, despues de la linea que evalua en que posicion de columna esta (If columna = 1 then), he colocado el siguiente codigo:

    fld.Cells(fila, columna).Selection.Numberformat = "0000000000000"

    Pero me arroja un error en tiempo de ejecicion que dice que el objeto no admite esta propiedad o metodo. Ahora bien, si le quito el fld y lo dejo así:

    .Cells(fila, columna).Selection.Numberformat = "0000000000000" me arroja un error de compilacion que dice no se ha definido Sub o Function

    He probado de muchas maneras pero siempre me sale error

     Les agradezco muchisimo me puedan ayudar con esto


    • Editado Alexsc007 sábado, 25 de febrero de 2012 22:46
    sábado, 25 de febrero de 2012 22:32

Respuestas

  • listo entonces , pego el codigo y te explico , el valor de la celda donde se esta escribiendo la cedula por defecto lo toma como valor numerico es por eso que los ceros desaparecen, asi que que hay que darle formato de texto a la celda para que acepte los ceros a la izquierda , te dejo el codigo y te resalto en negrita lo que tenes que cambiar.

    Sub ExportarAExcel()
    Dim cadSQL As String
    Dim libro As String
    Dim hoja As String
    Dim appExcel As Object 'Excel.Application
    Dim rst As Object 'DAO.Recordset
    Dim fld As Object 'DAO.Field
    Dim fila As Integer
    Dim columna As Integer
    Dim fechainicial As String
    Dim fechafinal As String

    fechainicial = InputBox("Ingrese Fecha Inicial dd/mm/aaaa", "Buscando...")
    fechafinal = InputBox("Ingrese Fecha Final dd/mm/aaaa", "Buscando...")
    cadSQL = "SELECT REGISTRO.CEDULA, REGISTRO.SUCURSAL, REGISTRO.CODIGO_CONCEPTO, REGISTRO.CENTRO_COSTO, REGISTRO.SUBCENTRO, REGISTRO.VARIABLE, REGISTRO.VALOR_NOVEDAD, REGISTRO.TIPO_COMPROBANTE, REGISTRO.CODIGO_COMPROBANTE, REGISTRO.NUM_DOCUMENTO_CRUCE, REGISTRO.SEC_DOCUMENTO_CRUCE FROM REGISTRO WHERE (((REGISTRO.FECHA_REGISTRO) >= '" & fechainicial & "' And (REGISTRO.FECHA_REGISTRO) <= '" & fechafinal & "'))"
    libro = "Libro1.xls"
    hoja = "Hoja1"

       ' abrimos excel, lo hacemos visible y abrimos el libro
       ' que nos interesa
       Set appExcel = CreateObject("Excel.Application")
       appExcel.Visible = True
       appExcel.Workbooks.Add
         
       ' abrimos la tabla, consulta o cadena sql en un
       ' recordset
       Set rst = CurrentDb.OpenRecordset(cadSQL)
      
       ' ponemos nombre a las columnas de la hoja igual que el
       ' nombre de los campos de la consulta
       fila = 1
       columna = 1
       With appExcel.Sheets(hoja)
          .Select
          For Each fld In rst.Fields
             .cells(fila, columna) = fld.Name
             columna = columna + 1
          Next
       
          ' después traspasamos el valor de los campos a las
          ' celdas de la hoja de excel
          fila = 2
          columna = 1
          While Not rst.EOF
             For Each fld In rst.Fields
                .cells(fila, columna) = fld.Value
               ' Call CeroIzquierda(fld.Value)
                If columna = 1 Then
                .cells(fila, columna).numberFormat = "@"
                .cells(fila, columna) = CeroIzquierda(fld.Value, 13)
                End If
                columna = columna + 1
             Next
             columna = 1
             fila = fila + 1
             rst.MoveNext
          Wend
         
       .Name = "Datos"
       End With

       rst.Close
      
       Set appExcel = Nothing

    End Sub

    Saludos , no se te olvide marcar la repuesta .


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:16
    domingo, 26 de febrero de 2012 23:27
  • Muchisimas gracias, me funciono perfactamente.

    Otra solucion que encontre probando de una y otra forma es esta:

    .cells(fila, columna).numberFormat = "@"
    .cells(fila, columna) = Format(fld.Value, "0000000000000")

    La segunda linea hace exactamente lo mismo que hace la funcion CerosIzquierda. Por supuesto, no hubiese podido encontrarla sin la ayuda que me brindaste.

    De nuevo mil y mil gracias


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:30
    lunes, 27 de febrero de 2012 0:30
  • Gracias, ya encontre la linea que me hace eso:

    .cells(fila, columna).EntireColumn.AutoFit


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:56
    lunes, 27 de febrero de 2012 0:56

Todas las respuestas

  • en efecto el formato que aplicas esta correcto, habria que ver si es un problema con excel o el tipo de dato , para resolver tu problema te voy a pasar esta funcion y la vas agregar en tu proyecto

    Function CeroIzquierda(Mnumero, Optional NoDig As Byte)
    On Error Resume Next
        Dim mDec As String
        Dim i As Integer
        If NoDig <> 0 Then
            mDec = ""
            For i = 1 To NoDig
                mDec = mDec + "0"
            Next i
            FormatNo = Format(Mnumero, mDec)
        Else
            FormatNo = Mnumero
        End If
    End Function

    en esta linea agregas la funcion

    .Cells(fila, columna) =CeroIzquierda( fld.Value,13)

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip


    domingo, 26 de febrero de 2012 1:02
  • Hola muchas gracias por tu respuesta:

    Podrias por favor explicarme un poco que hace esa funcion?? la verdad soy novato en esto de VBA y quisiera entender que proceso efectua dicha funcion. Muchas gracias


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 18:55
  • es equivalente a esto  fld.Cells(fila, columna).Selection.Numberformat = "0000000000000", con la diferencia que lo haces con una funcion que debes de pegar en un modulo de Access, recuerda que lo que esta fallando es el numberformat de excel por vba, para solucionar esto es por eso la funcion que te pase.

    Prubala y me dices como te resulto.

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 19:13
  • Agregue la Funcion al final del modulo en donde tengo el codigo que extrae y pega los datos en el excel, luego hice esto:

    fila = 2
    columna = 1
          While Not rst.EOF
             For Each fld In rst.Fields
                .Cells(fila, columna) = fld.Value
                Call CeroIzquierda(fld.Value)
                If columna = 1 Then
                .Cells(fila, columna) = CeroIzquierda(fld.Value, 13)
                End If
                columna = columna + 1
             Next
             columna = 1
             fila = fila + 1
             rst.MoveNext
          Wend

    Al ejecutar la macro paso a paso verifico que la funcion si esta agregando los ceroas a la izquierda (en este caso recibe como parametro de entrada 72048768 y finaliza asignando a FormatNo = 0000072048768), pero en el excel no esta quedando este ultimo valor si no esta quedando la celda en blanco.

    Hay algo que estoy haciendo mal???


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 20:12
  • me inmagino que quitaste esta linea fld.Cells(fila, columna).Selection.Numberformat = "0000000000000"?

    probemos realizar esto  .Cells(fila, columna) = str(CeroIzquierda(fld.Value, 13))

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 20:45
  • Por supuesto que quite esa linea.

    Probe con la modificacion que me diste pero ahora me deja un cero en cada celda de la columna A


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 21:33
  • disculpa modifica la funcion nuevamente ,ahora si te debe de funcionar

    Function CeroIzquierda(Mnumero, Optional NoDig As Byte)
    On Error Resume Next
        Dim mDec As String
        Dim i As Integer
        If NoDig <> 0 Then
            mDec = ""
            For i = 1 To NoDig
                mDec = mDec + "0"
            Next i
            CeroIzquierda = Format(Mnumero, mDec)
        Else
            CeroIzquierda = Mnumero
        End If
    End Function

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip


    domingo, 26 de febrero de 2012 21:43
  • El archivo de excel lo crea el modulo de VBA

    A continuacion el codigo completo:

    Sub ExportarAExcel()
    Dim cadSQL As String
    Dim libro As String
    Dim hoja As String
    Dim appExcel As Object 'Excel.Application
    Dim rst As Object 'DAO.Recordset
    Dim fld As Object 'DAO.Field
    Dim fila As Integer
    Dim columna As Integer
    Dim fechainicial As String
    Dim fechafinal As String

    fechainicial = InputBox("Ingrese Fecha Inicial dd/mm/aaaa", "Buscando...")
    fechafinal = InputBox("Ingrese Fecha Final dd/mm/aaaa", "Buscando...")
    cadSQL = "SELECT REGISTRO.CEDULA, REGISTRO.SUCURSAL, REGISTRO.CODIGO_CONCEPTO, REGISTRO.CENTRO_COSTO, REGISTRO.SUBCENTRO, REGISTRO.VARIABLE, REGISTRO.VALOR_NOVEDAD, REGISTRO.TIPO_COMPROBANTE, REGISTRO.CODIGO_COMPROBANTE, REGISTRO.NUM_DOCUMENTO_CRUCE, REGISTRO.SEC_DOCUMENTO_CRUCE FROM REGISTRO WHERE (((REGISTRO.FECHA_REGISTRO) >= '" & fechainicial & "' And (REGISTRO.FECHA_REGISTRO) <= '" & fechafinal & "'))"
    libro = "Libro1.xls"
    hoja = "Hoja1"

       ' abrimos excel, lo hacemos visible y abrimos el libro
       ' que nos interesa
       Set appExcel = CreateObject("Excel.Application")
       appExcel.Visible = True
       appExcel.Workbooks.Add
         
       ' abrimos la tabla, consulta o cadena sql en un
       ' recordset
       Set rst = CurrentDb.OpenRecordset(cadSQL)
      
       ' ponemos nombre a las columnas de la hoja igual que el
       ' nombre de los campos de la consulta
       fila = 1
       columna = 1
       With appExcel.Sheets(hoja)
          .Select
          For Each fld In rst.Fields
             .Cells(fila, columna) = fld.Name
             columna = columna + 1
          Next
       
          ' después traspasamos el valor de los campos a las
          ' celdas de la hoja de excel
          fila = 2
          columna = 1
          While Not rst.EOF
             For Each fld In rst.Fields
                .Cells(fila, columna) = fld.Value
                Call CeroIzquierda(fld.Value)
                If columna = 1 Then
                .Cells(fila, columna) = Str(CeroIzquierda(fld.Value, 13))
                End If
                columna = columna + 1
             Next
             columna = 1
             fila = fila + 1
             rst.MoveNext
          Wend
         
       .Name = "Datos"
       End With

       rst.Close
       
       Set appExcel = Nothing

    End Sub

    Function CeroIzquierda(Mnumero, Optional NoDig As Byte)
    On Error Resume Next
        Dim mDec As String
        Dim i As Integer
        If NoDig <> 0 Then
            mDec = ""
            For i = 1 To NoDig
                mDec = mDec + "0"
            Next i
            FormatNo = Format(Mnumero, mDec)
        Else
            FormatNo = Mnumero
        End If
    End Function

    Si deseas te puedo enviar a un correo electronico el proyecto completo para que lo examines y pruebes


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 21:50
  • prueba modificando la funcion CerosIzquierda

    disculpa modifica la funcion nuevamente ,ahora si te debe de funcionar

    Function CeroIzquierda(Mnumero, Optional NoDig As Byte)
    On Error Resume Next
        Dim mDec As String
        Dim i As Integer
        If NoDig <> 0 Then
            mDec = ""
            For i = 1 To NoDig
                mDec = mDec + "0"
            Next i
            CeroIzquierda = Format(Mnumero, mDec)
        Else
            CeroIzquierda = Mnumero
        End If
    End Function

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 21:54
  • Exactamente te iba a preguntar en que momento la funcion devolvia el valor formateado

    Ya realice la modificacion pero ahora me coloca en cada celda el valor traido de Access sin formato, es decir, 72048768

    Hace lo mismo que hace esta linea:

    .Cells(fila, columna) = Format(fld.Value, "0000000000000")


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 22:16
  • necesito que realizes lo siguiente

    1. .Cells(fila, columna) = Str(CeroIzquierda(fld.Value, 13)) sustituirla por  .Cells(fila, columna) = CeroIzquierda(fld.Value, 13)

    2. coloca un punto de interrupcion dentro de la funcion CerozIzquierda y detenlo propiamente aqui   CeroIzquierda = Format(Mnumero, mDec) , quiero que me muestres el resultado devuelto.

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 22:26
  • CeroIzquierda = Vacio

    Mnumero = "72048768"

    mDec = "0000000000000"

    En las celdas esta quedando el valor 72048768


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 22:41
  • disculpa modificaste la funcion CerosIzquierda por esta otra?????

    Function CeroIzquierda(Mnumero, Optional NoDig As Byte)
    On Error Resume Next
        Dim mDec As String
        Dim i As Integer
        If NoDig <> 0 Then
            mDec = ""
            For i = 1 To NoDig
                mDec = mDec + "0"
            Next i
            CeroIzquierda = Format(Mnumero, mDec)
        Else
            CeroIzquierda = Mnumero
        End If
    End Function


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 22:46
  • Sii tal cual

    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 22:49
  • enviame el proyecto entonces al correo capacitacionescorporativas@gmail.com, ya no se me ocurre nada mas, aunque luego posteemos la solucion

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    domingo, 26 de febrero de 2012 22:52
  • ok ahi te lo envié. Muchas gracias y quedo pendiente...

    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    domingo, 26 de febrero de 2012 22:58
  • listo entonces , pego el codigo y te explico , el valor de la celda donde se esta escribiendo la cedula por defecto lo toma como valor numerico es por eso que los ceros desaparecen, asi que que hay que darle formato de texto a la celda para que acepte los ceros a la izquierda , te dejo el codigo y te resalto en negrita lo que tenes que cambiar.

    Sub ExportarAExcel()
    Dim cadSQL As String
    Dim libro As String
    Dim hoja As String
    Dim appExcel As Object 'Excel.Application
    Dim rst As Object 'DAO.Recordset
    Dim fld As Object 'DAO.Field
    Dim fila As Integer
    Dim columna As Integer
    Dim fechainicial As String
    Dim fechafinal As String

    fechainicial = InputBox("Ingrese Fecha Inicial dd/mm/aaaa", "Buscando...")
    fechafinal = InputBox("Ingrese Fecha Final dd/mm/aaaa", "Buscando...")
    cadSQL = "SELECT REGISTRO.CEDULA, REGISTRO.SUCURSAL, REGISTRO.CODIGO_CONCEPTO, REGISTRO.CENTRO_COSTO, REGISTRO.SUBCENTRO, REGISTRO.VARIABLE, REGISTRO.VALOR_NOVEDAD, REGISTRO.TIPO_COMPROBANTE, REGISTRO.CODIGO_COMPROBANTE, REGISTRO.NUM_DOCUMENTO_CRUCE, REGISTRO.SEC_DOCUMENTO_CRUCE FROM REGISTRO WHERE (((REGISTRO.FECHA_REGISTRO) >= '" & fechainicial & "' And (REGISTRO.FECHA_REGISTRO) <= '" & fechafinal & "'))"
    libro = "Libro1.xls"
    hoja = "Hoja1"

       ' abrimos excel, lo hacemos visible y abrimos el libro
       ' que nos interesa
       Set appExcel = CreateObject("Excel.Application")
       appExcel.Visible = True
       appExcel.Workbooks.Add
         
       ' abrimos la tabla, consulta o cadena sql en un
       ' recordset
       Set rst = CurrentDb.OpenRecordset(cadSQL)
      
       ' ponemos nombre a las columnas de la hoja igual que el
       ' nombre de los campos de la consulta
       fila = 1
       columna = 1
       With appExcel.Sheets(hoja)
          .Select
          For Each fld In rst.Fields
             .cells(fila, columna) = fld.Name
             columna = columna + 1
          Next
       
          ' después traspasamos el valor de los campos a las
          ' celdas de la hoja de excel
          fila = 2
          columna = 1
          While Not rst.EOF
             For Each fld In rst.Fields
                .cells(fila, columna) = fld.Value
               ' Call CeroIzquierda(fld.Value)
                If columna = 1 Then
                .cells(fila, columna).numberFormat = "@"
                .cells(fila, columna) = CeroIzquierda(fld.Value, 13)
                End If
                columna = columna + 1
             Next
             columna = 1
             fila = fila + 1
             rst.MoveNext
          Wend
         
       .Name = "Datos"
       End With

       rst.Close
      
       Set appExcel = Nothing

    End Sub

    Saludos , no se te olvide marcar la repuesta .


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:16
    domingo, 26 de febrero de 2012 23:27
  • Realiza una macro en excel que te ajuste el contenido automatico y luego lo acomadas en tu funcion exportar ha excel.

    Saludos


    Capacitaciones Corporativas
    Si pequeña es la Patria, uno grande la sueña
    Rubén Darío
    Principe de las letras Castellanas
    Poeta Nicaragüense
    Ay Nicaragua, Nicaraguita Video Clip

    lunes, 27 de febrero de 2012 0:26
  • Muchisimas gracias, me funciono perfactamente.

    Otra solucion que encontre probando de una y otra forma es esta:

    .cells(fila, columna).numberFormat = "@"
    .cells(fila, columna) = Format(fld.Value, "0000000000000")

    La segunda linea hace exactamente lo mismo que hace la funcion CerosIzquierda. Por supuesto, no hubiese podido encontrarla sin la ayuda que me brindaste.

    De nuevo mil y mil gracias


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:30
    lunes, 27 de febrero de 2012 0:30
  • Gracias, ya encontre la linea que me hace eso:

    .cells(fila, columna).EntireColumn.AutoFit


    "El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..." Alexsc007 Bogotá - Colombia

    • Marcado como respuesta Alexsc007 lunes, 27 de febrero de 2012 0:56
    lunes, 27 de febrero de 2012 0:56