Extraer valores únicos, pegar y contar repeticiones excel vba
Para Dante
Dante buenos días, tengo aproximadamente 22 000 registros de libros en la hoja BIBLIOTECA.
Necesito una macro para extraer valores únicos, pegar y contar repeticiones como te muestro.
La primero ordenaría y después haría la petición con un progressbar.
,
resultado en la Hoja2, pase los nombres de los libros y el total de cada libro.
Estaré atento a sus instrucciones
3 respuestas
Te anexo la macro.
No es necesario ordenar los datos.
Tampoco es necesario un progress bar
Hice la prueba con 33,000 registros y la respuesta es inmediata.
Sub Contar_Areas()
'
'Por.Dante Amor
'
'
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
u1 = h1.Range("I" & Rows.Count).End(xlUp).Row
h1.Range("I4:I" & u1).Copy h2.Range("A1")
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Range("B2:B" & u2)
.FormulaR1C1 = "=COUNTIF(hoja1!C[7],Hoja2!RC[-1])"
.Value = .Value
End With
Application.ScreenUpdating = True
MsgBox "fin"
End Subsal u dos
Hola Dante gracias por tu apoyo, tal-vez falte un pequeño ajuste me sale valor cero
¿Modificaste la macro?
Según tu imagen, supongo que en la hoja1, en la celda I4, tienes el título "Área" y tus datos empiezan a partir de la celda I5.
Si no es así, entonces dime cómo están tus datos en la hoja1 para ajustar la macro.
Dante, solo cambié el el nombre de la hoja y mis datos empieza I4.
también te comento que algunas ÁREAS están en blanco, poco a poco voy corrigiendo
Sub Contar_Areas()
'Por.Dante Amor
'
'
Application.ScreenUpdating = False
Set h1 = Sheets("BIBLIOTECA")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
u1 = h1.Range("I" & Rows.Count).End(xlUp).Row
h1.Range("I5:I" & u1).Copy h2.Range("A1")
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Range("B2:B" & u2)
.FormulaR1C1 = "=COUNTIF(hoja1!C[7],Hoja2!RC[-1])"
.Value = .Value
End With
Application.ScreenUpdating = True
MsgBox "fin"
End Sub
Dante, te envié el archivo para que les un vistazo saludos!
Entones el rango debe empezar en I3
Y ajustar el nombre de la hoja en la fórmula, te anexo la macro actualizada
Sub Contar_Areas()
'Por.Dante Amor
'
'
Application.ScreenUpdating = False
Set h1 = Sheets("BIBLIOTECA")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
u1 = h1.Range("I" & Rows.Count).End(xlUp).Row
h1.Range("I3:I" & u1).Copy h2.Range("A1")
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Range("B2:B" & u2)
.FormulaR1C1 = "=COUNTIF('" & h1.Name & "'!C[7],Hoja2!RC[-1])"
.Value = .Value
End With
Application.ScreenUpdating = True
MsgBox "fin"
End Subsal u dos
Se que tu pregunta está dirigida directamente a Dante, pero te propongo la siguiente solución...:
Sub OrdenarExtraerContar()
Set c = Range("i" & Rows.Count).End(xlUp)
c.Select
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=c, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A2:i" & c.Row)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Hoja1").Range("i2:i" & c.Row).Copy
ActiveWorkbook.Worksheets("Hoja2").Select
ActiveSheet.Range("a3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Set c = Range("a" & Rows.Count).End(xlUp)
ActiveSheet.Range("$A$3:$A$" & c.Row).RemoveDuplicates Columns:=1, Header:=xlNo
Columns("A:A").EntireColumn.AutoFit
Set c = Range("a" & Rows.Count).End(xlUp)
Range("B3:B" & c.Row).Select
Selection.FormulaR1C1 = "=COUNTIF(Hoja1!C9,RC[-1])"
End Sub
me error se requiere un objeto
buen día ya lo corregí, pero sale con valor 0
De acuerdo con la imagen que enviaste en tu pregunta inicial, asumo que los registros inician en la fila 4, si es así, en tu archivo cambia:
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SetRange Range("A2:i" & c.Row)Por
With ActiveWorkbook.Worksheets("Hoja1").Sort
. SetRange Range("A4:i" & c.Row)y cambia también
ActiveWorkbook. Worksheets("Hoja1"). Range("i2:i" & c.Row).CopyPor
ActiveWorkbook. Worksheets("Hoja1").Range("i4:i" & c.Row).Copy
