Excel - Macro Borrado de lineas que no cumplan

   
Vista:

Macro Borrado de lineas que no cumplan

Publicado por Carlos (2 intervenciones) el 27/04/2017 18:04:03
Buenos días:

Necesito ayuda con una macro que me permita borrar FILAS que tenga la parte fila superior e inferior en blanco.


Captura

Como muestro en la imagen, tengo filas de 2 y tengo filas de 1, quisiera solo dejar las filas de 2 y quede 2 espacios en blanco entre ellas.

Espero me puedan ayudar
Carlos

(Adjunto Excel comprimido).
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana

Macro Borrado de lineas que no cumplan

Publicado por Antoni Masana (592 intervenciones) el 28/04/2017 16:41:35
Falta el fichero.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Macro Borrado de lineas que no cumplan

Publicado por Carlos (2 intervenciones) el 02/05/2017 16:10:12
Adjunto.

Gracias
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana

Macro Borrado de lineas que no cumplan

Publicado por Antoni Masana (592 intervenciones) el 03/05/2017 08:46:35
La Macro

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Borrar()
    Dim Linea As Long, Blancos As Byte, a As Byte, Num As Byte
 
    Linea = 1
    Do While True
       If Cells(Linea, 1) = "" Then
 
          ' --- Si debajo tiene 10 lineas en blanco finaliza
 
          Num = 0
          For a = Linea + 1 To Linea + 10
              If Cells(a, 1) = "" Then Num = Num + 1
          Next
          If Num = 10 Then Exit Do
 
          ' --- Si la Anterior y posterior estan vacias la borro
 
          If Cells(Linea - 1, 1) = "" And Cells(Linea + 1, 1) = "" Then
             Rows(Linea & ":" & Linea).Select
             Selection.Delete Shift:=xlUp
             Linea = Linea - 1
          End If
       End If
       Linea = Linea + 1
    Loop
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar