Aplicar Formato Personalizado a Celdas desde VBA

Question

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

---

Answer 1

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

Answer 2

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

Answer 3

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

Answer 4

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

Answer 5

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

Answer 6

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

Answer 7

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

Answer 8

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

Answer 9

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

Answer 10

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

Answer 11

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

Answer 12

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

Answer 13

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

Answer 14

Sii tal cual

---

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

Answer 15

enviame el proyecto entonces al correo [e-mail], 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

Answer 16

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

Answer 17

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

Answer 18

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

Answer 19

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

Answer 20

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