Macro que no funciona.
Hola experto, tengo una macro larguísima que copia dos datos de una hoja ("SIMPLE MUST MOVE") a otra columna de la misma hoja y en otra hoja("REGISTRO"). Necesito que los datos en la hoja de registro aparezcan bordeados arriba y abajo. No se programar, lo que hago es copiar programas que vosotros publicáis y los adapto como puedo a mis necesidades, pero esta vez no doy con la clave. Con lo que he añadido si que bordea los datos en la hoja de registro pero en la hoja ("SIMPLE MUST MOVE") aparecen transformados en cifras. Esta es la macro, sólo copio un trozo que si no es demasiado larga y no me deja enviárosla ( en negrita lo que he añadido, sin ello funciona perfectamente):
Public snCambioE4 As Boolean
Public ORIGEN1 As String
Public ORIGEN3 As String
Sub CrearaRegistro3()
ORIGEN1 = "REGISTRO"
ORIGEN3 = "SIMPLE MUST MOVE"
copiaValorB5enHoja2a Cells(5, 4)
copiaValorB6enHoja2a Cells(5, 8)
copiaValorB5enHoja1a Cells(5, 4)
copiaValorB6enHoja1a Cells(5, 8)
Sheets(ORIGEN3).Select
Cells(5, 4).Select
End Sub
Private Sub copiaValorB5enHoja2a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
' Buscaremos de forma rápida la última línea grabada
' Primero de 1000 en 1000 hasta que no haya nada
nLin = 2
Do While Sheets(ORIGEN1).Cells(nLin, 2) <> ""
nLin = nLin + 1000
Loop
' Volvemos hacia atras de 25 en 25 hasta que haya una ocupada
Do While Sheets(ORIGEN1).Cells(nLin, 2) = ""
If nLin > 25 Then nLin = nLin - 25 Else Exit Do
Loop
' Y buscamos de 1 en 1 hacia delante hasta que haya una libre
Do While Sheets(ORIGEN1).Cells(nLin, 2) <> ""
nLin = nLin + 1
Loop
With Worksheets("REGISTRO").Activate
Range(Cells(nLin, 2), Cells(nLin, 8)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Sheets(ORIGEN1).Cells(nLin, 2) = valorB5
Sheets(ORIGEN1).Cells(nLin, 4) = Time()
Sheets(ORIGEN1).Cells(nLin, 7) = "TX 5/10"
End Sub
Private Sub copiaValorB6enHoja2a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
nLin = 2
Do While Sheets(ORIGEN1).Cells(nLin, 3) <> ""
nLin = nLin + 1000
Loop
(corto un trozo,,,es lo mismo para la otra celda,,,,,,,,)
Private Sub copiaValorB5enHoja1a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
' Buscaremos de forma rápida la última línea grabada
' Primero de 1000 en 1000 hasta que no haya nada
nLin = 3
Do While Sheets(ORIGEN3).Cells(nLin, 11) <> ""
nLin = nLin + 1000
Loop
( Y aquí también corto que es muy largo, pero no he modificado nada, es lo mismo pero en (ORIGEN3), y en las celdas (nLin, 11) y (nLin, 12)
End Sub
Public snCambioE4 As Boolean
Public ORIGEN1 As String
Public ORIGEN3 As String
Sub CrearaRegistro3()
ORIGEN1 = "REGISTRO"
ORIGEN3 = "SIMPLE MUST MOVE"
copiaValorB5enHoja2a Cells(5, 4)
copiaValorB6enHoja2a Cells(5, 8)
copiaValorB5enHoja1a Cells(5, 4)
copiaValorB6enHoja1a Cells(5, 8)
Sheets(ORIGEN3).Select
Cells(5, 4).Select
End Sub
Private Sub copiaValorB5enHoja2a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
' Buscaremos de forma rápida la última línea grabada
' Primero de 1000 en 1000 hasta que no haya nada
nLin = 2
Do While Sheets(ORIGEN1).Cells(nLin, 2) <> ""
nLin = nLin + 1000
Loop
' Volvemos hacia atras de 25 en 25 hasta que haya una ocupada
Do While Sheets(ORIGEN1).Cells(nLin, 2) = ""
If nLin > 25 Then nLin = nLin - 25 Else Exit Do
Loop
' Y buscamos de 1 en 1 hacia delante hasta que haya una libre
Do While Sheets(ORIGEN1).Cells(nLin, 2) <> ""
nLin = nLin + 1
Loop
With Worksheets("REGISTRO").Activate
Range(Cells(nLin, 2), Cells(nLin, 8)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Sheets(ORIGEN1).Cells(nLin, 2) = valorB5
Sheets(ORIGEN1).Cells(nLin, 4) = Time()
Sheets(ORIGEN1).Cells(nLin, 7) = "TX 5/10"
End Sub
Private Sub copiaValorB6enHoja2a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
nLin = 2
Do While Sheets(ORIGEN1).Cells(nLin, 3) <> ""
nLin = nLin + 1000
Loop
(corto un trozo,,,es lo mismo para la otra celda,,,,,,,,)
Private Sub copiaValorB5enHoja1a(ByVal valorB5)
Dim nLin As Long
If IsNull(valorB5) Or valorB5 = "" Then Exit Sub
' Buscaremos de forma rápida la última línea grabada
' Primero de 1000 en 1000 hasta que no haya nada
nLin = 3
Do While Sheets(ORIGEN3).Cells(nLin, 11) <> ""
nLin = nLin + 1000
Loop
( Y aquí también corto que es muy largo, pero no he modificado nada, es lo mismo pero en (ORIGEN3), y en las celdas (nLin, 11) y (nLin, 12)
End Sub
{"Lat":38.8225909761771,"Lng":-4.921875}
1 respuesta
Respuesta de wynd
1