Mantener la misma forma en las casillas despues de crear un nuevo cuaderno

[OscarPerez]

Hola,

Tengo un problema cuando salvo un cuaderno a un nuevo cuaderno las casillas no estan formadas igualmente como el cuaderno original.

La casilla original esta formada de la forma siguiente:

1) Horizontal Alignment = Justify
2) Vertical Alignment = Top
3) Wrap Text = True
4) Merge Cells = True

La information de estas casillas no son copiadas completamente son cortadas, lo cual tengo que terminarlas de llenar manualmente.

Trate de usar el siguiente codigo en rojo:

Private Sub CommandButton2_Click()
Dim SaveName As String
SaveName = ActiveSheet.Range("E25").Text
Sheets("Nonconformance Report").Copy
ActiveWorkbook.SaveAs Filename:="G:\EyeBank\QS\Audits\NCR Files\" & _SaveName & ".xls"
.HorinzontalAlignment = xlJustify
.VerticalAlignment = xlTop
.WrapText = True
.MergeCell = True

MsgBox "Save As " & SaveName & ".xls"

ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveSheet.Shapes("CommandButton4").Delete
ActiveSheet.Shapes("CommandButton7").Delete

ActiveWorkbook.Close SaveChanges:=True
End Sub

Que puede hacer para mantener el mismo formato en el nuevo cuaderno?

Gracias de antemanos!

 

[Greg Truby]

Hola Oscar

Bueno - el primer problema que tengo es que no puedo duplicar su problema. Si hago una hoja con celdas unidas (merged) y varias propiedades sobre alinamiento, y copy tal hoja con VBA, sí me copia esas propiedades de formato. Probé en Excel 2007 y 2003 (usted no indica cuál versión de Excel está usando).

Número 2: Código que sigue un guión bajo debe de venir en una línea separada o sea

'// eso no
ActiveWorkbook.SaveAs Filename:="G:\EyeBank\QS\Audits\NCR Files\" & _SaveName & ".xls"
 
'// eso sí
ActiveWorkbook.SaveAs Filename:="G:\EyeBank\QS\Audits\NCR Files\" & _
SaveName & ".xls"

Número 3: Estás deletreados mal dos de las propiedades y mal especificados unos constantes:

[COLOR=red]'// esto no[/COLOR]
[COLOR=red].Hori[B][U]n[/U][/B]zontalAlignment = xlJustify[/COLOR]
[COLOR=#ff0000].MergeCell = True[/COLOR]
 
[COLOR=black]'//esto sí[/COLOR]
[COLOR=black].HorizontalAlignment = XlHAlign.xlHAlignJustify[/COLOR]
[COLOR=black].MergeCell[B][U]s[/U][/B] = True[/COLOR]

Número 4: Le falta el objeto a lo cual pertenece estas propiedades. Es decir el "padre" de estas propiedades que se especifica con un WITH statement:

With rngRangoDeCeldas
    .HorizontalAlignment= XlHAlign.xlHAlignJustify
    .VerticalAlignment = XlVAlign.xlVAlignTop
    .WrapText = True
    .MergeCells = True
End With

 

[OscarPerez]

OK, uso 2003 y cambie mis errores:

Private Sub CommandButton2_Click()
Dim SaveName As String
SaveName = ActiveSheet.Range("E25").Text
Sheets("Nonconformance Report").Copy
ActiveWorkbook.SaveAs Filename:="G:\EyeBank\QS\Audits\NCR Files\" & SaveName & ".xls"
With Range("B5:K5,B7:K7,B9:K9,B11:K11,B13:K13,B15:K15,B17:K17")
.HorizontalAlignment = XlHAlign.xlHAlignJustify
.VerticalAlignment = XlVAlign.xlVAlignTop
.WrapText = True
.MergeCells = True
End With
MsgBox "Save As " & SaveName & ".xls"

ActiveSheet.Shapes("CommandButton1").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveSheet.Shapes("CommandButton4").Delete
ActiveSheet.Shapes("CommandButton7").Delete

ActiveWorkbook.Close SaveChanges:=True
End Sub

Las celdas emergen desde B hasta K, lo alto de la celda es 15.00
Ahora bien, cuando es mas de 10 lineas de sentencias, lo alto cambia a 33.00, pero cuando se traspasa al nuevo cuaderno las sentencias estan cortadas. Lo alto y ancho esta bien pero el contenido no es completo.

 

[Greg Truby]

Bueno, eso sí creo. Porque con Excel 2003 y abajo cuando uno copia una hoja, cualquiera celda que contenga más de 255 caracteres queda cortada a los primero 255. Usted tendría que hacer una copiar y pegar celda por celda para las que tiene más de 255 caracteres. Arreglaron eso con Excel 2007.

 

[OscarPerez]

Me pdria explicar como copiar y pegar celda por celda con el mismo codigo!

 

[galileogali]

te recomiendo utilizar

Dim rngCell as Range

>>>>>>>>>>>
If rngCell <>"" then

RangoDestino(i +1).value = rngCell.value
End If
i= i +1

Next rngCell

Si los rangos de Origen y Destino son algo como esto
Range("B5:K5,B7:K7,B9:K9,B11:K11,B13:K13,B15:K15,B17:K17")
pero difieren tan solo en el Libro y en la Hoja, pero no en las referencias de celda, entonces el For Each se puede restringir a recorrer este MultiRango, para eso cambiar esto
for each rngCell in RangoOrigen
por
for each rngCell in RangoOrigen.cells

Lo ideal sería Set(ear) los Rangos de origeny el de destino