Cambio de columnas en una macro Excel para borrar filas
Necesitaría cambiar las columnas, sobre una macro creada para trabajar sobre las columnas A, B y C, a otras columnas.
La macro borra las filas cumpliendo una doble condición:
COLUMNA A: Fecha
COLUMNA B: Proveedor
COLUMNA C: Nº Expediente
Necesitaría cambiar por:
COLUMNA A: Expediente
COLUMNA AU: Proveedor
COLUMNA T: Fecha
Sub BorrarFilas()'Por.Dante Amor' Application.ScreenUpdating = False Application.DisplayAlerts = False Set h1 = Sheets("Hoja1") Set h2 = Sheets.Add 'Set h2 = Sheets("Hoja4") 'h2.Cells.Clear h1.Columns("C:C").Copy h2.[A1] h1.Columns("B:B").Copy h2.[B1] u = h1.Range("A" & Rows.Count).End(xlUp).Row ' With h1.Sort .SortFields.Clear .SortFields.Add Key:=h1.Range("A2:A" & u), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=h1.Range("B2:B" & u), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=h1.Range("C2:C" & u), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange h1.Range("A1:C" & u) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' h2.Range("A1:B" & u).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes h2.Range("A1:B1").Copy h2.[D1] For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row h2.Range("A" & i & ":B" & i).Copy h2.[D2] If h1.FilterMode Then h1.ShowAllData h1.Range("A1:C" & u).AdvancedFilter Action:=xlFilterInPlace, _ CriteriaRange:=h2.Range("D1:E2"), Unique:=False ' u3 = h1.Range("A" & Rows.Count).End(xlUp).Row fin = u3 If u3 > 2 Then For j = u3 - 1 To 2 Step -1 If h1.Cells(j, "A").EntireRow.Hidden = False Then h2.Cells(j, "G") = "x" End If Next End If Next ' If h1.FilterMode Then h1.ShowAllData For k = u To 2 Step -1 If h2.Cells(k, "G") = "x" Then h1.Rows(k).Delete End If Next h2.Delete Application.ScreenUpdating = True ' MsgBox "fin"End Sub
Respuesta de Dante Amor
1
Te anexo la macro actualizada
Sub BorrarFilas()
'Por.Dante Amor
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets.Add
'Set h2 = Sheets("Hoja4")
'h2.Cells.Clear
h1.Columns("A:A").Copy h2.[A1]
h1.Columns("AU:AU").Copy h2.[B1]
u = h1.Range("T" & Rows.Count).End(xlUp).Row
'
With h1.Sort
.SortFields.Clear
.SortFields.Add Key:=h1.Range("T2:T" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange h1.Range("A1:AU" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
h2.Range("A1:B" & u).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
h2.Range("A1:B1").Copy h2.[D1]
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A" & i & ":B" & i).Copy h2.[D2]
If h1.FilterMode Then h1.ShowAllData
h1.Range("A1:AU" & u).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=h2.Range("D1:E2"), Unique:=False
'
u3 = h1.Range("A" & Rows.Count).End(xlUp).Row
fin = u3
If u3 > 2 Then
For j = u3 - 1 To 2 Step -1
If h1.Cells(j, "A").EntireRow.Hidden = False Then
h2.Cells(j, "AZ") = "x"
End If
Next
End If
Next
'
If h1.FilterMode Then h1.ShowAllData
For k = u To 2 Step -1
If h2.Cells(k, "AZ") = "x" Then
h1.Rows(k).Delete
End If
Next
h2.Delete
Application.ScreenUpdating = True
'
MsgBox "fin"
End SubSaludos.Dante Amor
Recuerda valorar la respuesta.
