Al eliminar línea en Página, se descombinan las celdas en Página 2
Para DanteAmor
De nuevo Dante. No recordaba la pregunta
En ese mismo archivo, cuando elimino una o más líneas en PAGINA1, en PAGINA2 desaparece la combinación de celdas entre DE y I como puedes observar en la imagen. Si elimino en la página 2 nada pasa, todo corre bien
For i = 11 To 46
Range("D" & i & ":I" & i).Merge
Range("D" & i & ":I" & i).HorizontalAlignment = xlCenter
Range("O" & i & ":T" & i).Merge
Range("O" & i & ":T" & i).VerticalAlignment = xlCenter
Next
Para otra pregunta es que al eliminar línea(s) en PAGINA1, si hay datos en pagina2, al trasladar hacia la pagina1, en la celda B de la página 1, me inserta(traslada y me queda la B sin el formato personalizado (000)
Estos 2 puntos, no son de ahora, ya hace tiempo, creo que desde un principio, aunque tengo la columna B y M con formato personalizado 000
1 Respuesta
Esa misma que tienes, la ultima que te envíe, pero te enviaré nuevamente.
Lo que hago es usar la plantilla, la lleno y mando crear un archivo XLSX y otro PDF y la plantilla sigue como si nada.
Pero mientras lleno, si llene la Página 1 y sigo en la Página 2, pero por alguna circunstancia tengo que eliminar alguna línea en la Página 1, sucede que en el traslado de línea datos de la página 2 hacia la página 1, el combinado de celdas en la página 2 desaparece.
Voy enviarte un otro
Te anexo el código
Const GWL_STYLE = -16
Const WS_CAPTION = &HC00000
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Cerrar formulario
Private Sub cbtCera_Click()
Application.ScreenUpdating = False
Set h2 = Sheets("filtro")
h2.Unprotect Password:="By Jot@"
h2.Cells.Clear 'Contents
Unload Me
h2.Protect Password:="By Jot@"
Application.ScreenUpdating = True
End Sub
'Elimina y vuelve a filtrar para actualisar tabla.
Private Sub cbtElimi_Click()
'Por.Dante Amor http://www.todoexpertos.com/preguntas/6tq7iumqenw3rrpx/eliminar-los-registros-seleccionados-en-el-listbox
'Eliminar el registro
ActiveSheet.Unprotect Password:="By Jot@"
If Lista2.ListIndex = -1 Then
MsgBox "No hay registros"
Exit Sub
End If
seleccionado = False
For i = 0 To Lista2.ListCount - 1
If Lista2.Selected(i) Then
seleccionado = True
Exit For
End If
Next
If seleccionado = False Then
MsgBox "Selecciona un registro"
Exit Sub
End If
Pregunta = MsgBox("Está seguro para eliminar el registro?", vbYesNo + vbQuestion, "Eliminación")
If Pregunta = vbNo Then Exit Sub
'Selecciona la pagina
If OptionButton1 Then
c1 = "B": c2 = "K": c3 = "C": c4 = "D"
ElseIf OptionButton2 Then
c1 = "M": c2 = "V": c3 = "N": c4 = "O"
End If
'Elimina lo seleccionado
Application.ScreenUpdating = False
For i = Lista2.ListCount - 1 To 0 Step -1
If Lista2.Selected(i) Then
fila = Lista2.List(i, 10)
If fila < 46 Then
Range(c1 & fila + 1 & ":" & c2 & 46).Copy Range(c1 & fila)
End If
Range(c1 & 46 & ":" & c2 & 46).ClearContents
'Mover registro de página 2
If Range("M11") <> "" Then
Range("B46") = Range("M11")
Range("C46") = Range("N11")
Range("D46") = Range("O11")
Range("J46") = Range("U11")
Range("K46") = Range("V11")
Range("M12:V46").Copy Range("M11")
End If
End If
Next
Call FiltrarLista2(c1, c2, c3, c4, True)
'Combina las celdas D:I y O:T y da formato centrado
Application.ScreenUpdating = False
For i = 11 To 46
Range("D" & i & ":I" & i).Merge
Range("D" & i & ":I" & i).HorizontalAlignment = xlCenter
Range("O" & i & ":T" & i).Merge
Range("O" & i & ":T" & i).VerticalAlignment = xlCenter
Next
Range("B11:B46").NumberFormat = "000"
Range("M11:M46").NumberFormat = "000"
ActiveSheet.Protect Password:="By Jot@"
Application.ScreenUpdating = True
End Sub
'
'Mostrar resultado filtrados, por el boton Filtro en ListBox
Private Sub cbtFiltro_Click() 'LISTO
'Por.Dante Amor http://www.todoexpertos.com/preguntas/6tq6n98o8eefyo4j/arreglar-la-macro-para-filtrar-con-el-textbox?nid=gcqp5uuggnw63hkphks99g6ma4qp9tm5gso6jgulabr3&utm_source=todoexpertos&utm_medium=EmailNotification&utm_campaign=AskerQuestion_ExpertMessageAdded
If OptionButton1 Then
Call FiltrarLista2("B", "K", "C", "D") 'inicio y fin de rango y filtrar por columna C y D
ElseIf OptionButton2 Then
Call FiltrarLista2("M", "V", "N", "O") 'inicio y fin de rango y filtrar por columna N y O
Else
'Si no existe ningun Option seleccionado, manda mensaje
MsgBox "selecciona una página", vbCritical, "Selección"
End If
End Sub
'Activar la (linea) del rango (OptionButton) elegido.ESTA EN VEREMOS
Private Sub Lista2_Click()
Range("a2").Activate
Cuenta = Lista2.ListCount
Set rango = Range("A1").CurrentRegion
For i = 0 To Cuenta - 1
If Lista2.Selected(i) Then
Valor = Lista2.List(i)
rango.Find(what:=Valor, LookAt:=xlWhole, After:=ActiveCell).Activate
End If
Next i
End Sub
'Filtrado con los OptionButton LISTO
'Nuevo por Dante
Private Sub OptionButton1_Click()
Call FiltrarLista2("B", "K", "C", "D") 'inicio y fin de rango y filtrar por columna C y D
End Sub
Private Sub OptionButton2_Click()
Call FiltrarLista2("M", "V", "N", "O") 'inicio y fin de rango y filtrar por columna N y O
End Sub
Sub FiltrarLista2(col1, col2, col3, col4, Optional verifica As Boolean)
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Lista Repuestos")
Set h2 = Sheets("filtro")
h2.Unprotect Password:="By Jot@"
h2.Cells.Clear 'Contents
Lista2.RowSource = ""
fila = 46
h1.Range("B10:K10").Copy h2.Range("A1")
j = 2
For i = 11 To 46
If Cells(i, col1) <> "" And _
UCase(h1.Cells(i, col3) & h1.Cells(i, col4)) Like "*" & UCase(txtFiltro) & "*" Then
h1.Range(col1 & i & ":" & col2 & i).Copy h2.Cells(j, "A")
h2.Cells(j, "K") = i
j = j + 1
End If
Next
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
If u2 > 1 Then
Lista2.RowSource = h2.Name & "!A2:K" & u2
Else
If verifica = False Then
MsgBox "No se encuentra.", vbExclamation, "Inexistente"
End If
End If
h2.Protect Password:="By Jot@"
Application.ScreenUpdating = True
End Sub
'Dar formato al ListBox y traer datos de la tabla
Private Sub UserForm_Initialize()
frmEliminar.Height = 220
frmEliminar.Width = 405
'Ocultar barra de titulo
Dim lngWindow As Long, lFrmHdl As Long
lFrmHdl = FindWindowA(vbNullString, Me.Caption)
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Hola Dante
Volví por undécima ves copiar TODA las macros que dejaste en esta pregunta.
Eliminando en la página 1, traslada de la pagina2 hacia la página 1 bien, sea eliminando solo una línea o 3 y el formato en la B queda y también la combinación de celdas en la 2; BIEN.
Eliminando en la Página 2 NO tenia porque tocar en la Página 1 y si lo hace.
Si elimino en Pagina2 una sola línea, elimina la ultima de la página 1 para trasladar la 1ª línea de la página 2 hacia la página 1 si elimino 3 de la 2, elimina las 3 ultimas de la 1 para trasladar de la 2 hacia la 1.
Elimine las 3 primeras ROLINERA de la página 2 y me paso hacia pagina1 los 3 primeros renglones y me dejo una rolinera (que no elimino)
Puse la macro para que veas los cambios, pero tienes que probar en el archivo que te envié.
Hola Dante
Si probé pero en especial cuando elimino en página 2 me lo hacwe también en página 1 la o las ultimas líneas dependiendo si selecciono una o más líneas para eliminar. Eliminándolas me lo hace también en las ultimas de la Pagina1 y hace el traslado de la 2 hacia la 1
Agregué esta línea
Range("M46:V46"). ClearContentsPrueba la versión D que te envié
Dante Crearé nueva pregunta para lo del formato
"Dar formato a celdas mde determinada columna con macro"
Esa línea
Range("M46:V46"). ClearContentsno la encuentro en ninguna parte del código en general del Celdas N_T combinadas_formato person en C ni del B
Hablas en: Prueba la versión DE que te envié . La DE no la recibí pero esta ultima es la C que probé y ya te explique en un mail
Saludos y mil gracias
Lo que si le falta es el mensaje SOLO de cuando TRASLADA DE LA 2 HACIA LA 1 si no traslada no haría falta (CREO)
No es necesario el mensaje, todo quedó automático
Solo esta
La macro Sub AcomodLinP2aP1() puedo eliminar ese modulo TrasladoLinea?
Sí
