Principales respuestas
Aplicar Formato Personalizado a Celdas desde VBA

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
WendSin 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
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 Stringfechainicial = 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 Withrst.Close
Set appExcel = NothingEnd 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
-
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
-
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
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 Functionen 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- Editado Capacitaciones Corporativas domingo, 26 de febrero de 2012 1:05
-
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
-
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 -
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
WendAl 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
-
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 -
-
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 FunctionSaludos
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- Editado Capacitaciones Corporativas domingo, 26 de febrero de 2012 21:48
-
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 Stringfechainicial = 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 Withrst.Close
Set appExcel = NothingEnd 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 FunctionSi 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
-
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 FunctionSaludos
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- Propuesto como respuesta Capacitaciones Corporativas domingo, 26 de febrero de 2012 21:55
-
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
-
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 -
-
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 FunctionCapacitaciones 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 -
-
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 -
-
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 Stringfechainicial = 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 Withrst.Close
Set appExcel = NothingEnd 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
-
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 -
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
-
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