Insertar Columna en Excel con Macro
Hola, nos hizo falta una columna, no la he insertado, pero la idea es que quede después de la C.
Me puedes ayudar a insertarla y recorrer la macro?
Te agradezco mucho
Respuesta de Dante Amor
1
Te anexo la macro
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
'End
clave = "abc"
'
If Not Intersect(Target, Range("A:H, J:J")) Is Nothing Then
ActiveSheet.Unprotect clave
Application.ScreenUpdating = False
Application.EnableEvents = False
'
For Each c In Target
Range("K2:M2").Copy Cells(c.Row, "K")
Next
'
c1 = "E"
c2 = "G"
c3 = "H"
u = Range("A" & Rows.Count).End(xlUp).Row
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range(c1 & "2:" & c1 & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range(c2 & "2:" & c2 & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range(c3 & "2:" & c3 & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:M" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
an1 = Cells(2, c1)
an2 = Cells(2, c2)
an3 = Cells(2, c3)
con = 0
For i = 2 To u
If an1 = Cells(i, c1) And _
an2 = Cells(i, c2) And _
an3 = Cells(i, c3) Then
con = con + 1
Else
con = 1
End If
Cells(i, "I") = con
an1 = Cells(i, c1)
an2 = Cells(i, c2)
an3 = Cells(i, c3)
Next
'
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:M" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
If Not Intersect(Target, Range("J:J")) Is Nothing Then
Range("A" & Target.Row & ":J" & Target.Row).Locked = True
End If
'
ActiveSheet.Protect clave, DrawingObjects:=False, Contents:=True, _
Scenarios:=False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
'
Application.EnableEvents = True
End If
End Sub
