Macro para ocultar celdas vacías
Para dante
Podrías ayudarme
Necesito una macro para ocultar celdas vacías y solo mostrar aquellas que contienen datos en la columna C. Y que pueda usar la macro en cada hoja ( son 5 hojas: Medicamentos, Planificación F., Quirúrgico, M. De Oficina, M. De Limpieza) y que la macro funcione cuando selecciono una de esas hojas con los optionbutton que aparecen arriba del formulario.
1 respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo el código para ocultar:
'ocultar celdas vacias (filtro) y solo mostrar aquellas que contienen datos en la columna C
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:="<>"La macro completa:
Private Sub filtrard_click()
Dim fec1 As Date, fec2 As Date
'Application.ScreenUpdating = False
'controlar que haya algún OB seleccionado
If OptionButton1.Value = False And OptionButton2.Value = False And OptionButton3.Value = False And OptionButton4.Value = False And OptionButton5.Value = False Then
MsgBox "Debes seleccionar algún botón de Cliente. Luego ejecuta nuevamente el botón de guardado.", , "ERROR"
Exit Sub
End If
'------------
'
'ocultar celdas vacias (filtro) y solo mostrar aquellas que contienen datos en la columna C
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:="<>"
'
Set hm = Sheets("filtros")
'borra filas de filtros anteriores manteniendo los titulos
'hm.Rows("2:" & hm.Range("A" & Rows.Count).End(xlUp).Row).Delete
hm.Cells.Clear
fec1 = TextBox1
fec2 = TextBox2
Hoja = ActiveSheet.Name 'no haria falta xq estas en la hoja elegida
j = 4 'siempre sera la col 2
For i = 2 To Sheets(Hoja).Range("A" & Rows.Count).End(xlUp).Row
If Sheets(Hoja).Cells(i, j) >= fec1 And Sheets(Hoja).Cells(i, j) <= fec2 Then
u = hm.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(Hoja).Rows(i).Copy
'pegar solo valores y formatos
hm.Rows(u).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
hm.Rows(u).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
hm.Cells(u, j).Interior.ColorIndex = 4
End If
Next
'
'With hm.Cells
' .Borders(xlEdgeLeft).LineStyle = xlNone
' .Borders(xlEdgeTop).LineStyle = xlNone
' .Borders(xlEdgeBottom).LineStyle = xlNone
' .Borders(xlEdgeRight).LineStyle = xlNone
' .Borders(xlInsideVertical).LineStyle = xlNone
' .Borders(xlInsideHorizontal).LineStyle = xlNone
'End With
With hm.UsedRange
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Range("a2").Select
Application.ScreenUpdating = True
End With
'
u = hm.Range("A" & Rows.Count).End(xlUp).Row
With hm.Sort
.SortFields.Clear
.SortFields.Add Key:=hm.Range("A1:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange hm.Range("A1:I" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call copiar
'Unload Me 'filtrar 'UserForm1
Sheets("filtros").Select
'Call Columna
Columns("J").EntireColumn.Hidden = True
Columns("K").EntireColumn.Hidden = True
Columns("L").EntireColumn.Hidden = True
Columns("M").EntireColumn.Hidden = True
Columns("N").EntireColumn.Hidden = True
Range("A2").Select
TextBox1 = ""
TextBox2 = ""
OptionButton1.Value = False
OptionButton2.Value = False
OptionButton3.Value = False
OptionButton4.Value = False
OptionButton5.Value = False
End SubPara mostrar:
On Error Resume Next For Each h In Sheets h.ShowAllData Next On Error GoTo 0
La macro completa:
Private Sub CommandButton3_Click()
TextBox1 = ""
TextBox2 = ""
Range("A2").Select
On Error Resume Next
For Each h In Sheets
h.ShowAllData
Next
On Error GoTo 0
OptionButton1.Value = False
OptionButton2.Value = False
OptionButton3.Value = False
OptionButton4.Value = False
OptionButton5.Value = False
Filtrar2.Hide
ThisWorkbook.Application.Visible = False
Set hm = Sheets("filtros")
hm.Cells.Clear
Load Menu
Menu.Show
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
