Excel - Ayuda para dividir libro excel

 
Vista:

Ayuda para dividir libro excel

Publicado por Jorge (1 intervención) el 23/10/2017 16:45:12
Hola, muy buenos días.

Estoy haciendo una macro que lo que hace es recorrerse todas las hojas del libro menos la primera para eliminar todos los valores de la columna A que no sean el nombre de la delegación X o espacio en blanco. Tengo definido el nombre de la delegación en la hoja valores, celda A4.

Quería ampliar ese rango de valores para meter 20 delegaciones distintas y me guardase una copia del propio archivo con el nombre de la delegación en la propia carpeta donde se encuentra el archivo base

Es decir, el objetivo final es dividir el fichero base en 20 subarchivos con la información de cada delegación.

Hasta ahora lo que he programado es esto:

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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Option Explicit
Sub BorrarDelegacion()
Dim i As Byte
Dim RangoFuente As Range
Dim RangoBorrar As Range
Dim Celda       As Range
Dim Primero     As Boolean
Dim Delegacion  As Range
 
Set Delegacion = Worksheets("Valores").Range("A4")
 
'Hacemos un For para recorrer todas las delegaciones
' Esto es lo que estoy haciendo. para Set RangoDelegacion = Worksheets("Valores").
' For Each Delegacion In RangoDelegacion
 
'Hacemos un For para recorrer todas las hojas desde la segunda hoja
For i = 2 To ThisWorkbook.Sheets.Count
 
    ThisWorkbook.Sheets(i).Select
 
    On Error Resume Next
'Dentro de la hoja activa recorremos todas las celdas
    Set RangoFuente = Range("A4:A" & Range("A65536").End(xlUp).Row)
    Primero = True
    For Each Celda In RangoFuente
 
'Borramos todas las que no coincidan con la delegación de turno o espacio en blanco
        If (Celda.Value <> Delegacion And Celda.Value <> "") Then
            If Primero Then
                Set RangoBorrar = Celda.EntireRow
                Primero = False
            Else
                Set RangoBorrar = Union(RangoBorrar, Celda.EntireRow)
            End If
        End If
    Next
 
    RangoBorrar.Delete
Next
 
'Next
End Sub

Os dejo un ficherito donde se puede hacer una prueba. La macro se encuentra en "This Workbook"

Estoy un poco bloqueado con el asunto, os estaría plenamente agradecido si me pudieséis echar una mano con el asunto.

Muchas gracias
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