Macro para comparar y contar de un otro en Excel VBA
Tengo la siguiente macro, que abre el libro2 lo compara por código y luego cuenta por 12 criterios y los resultados debe posicionarse en las columnas correspondientes del LIBRO1.
En el libro2 en la columna "Q" están los diferentes criterios a realizar el conteo en mi ejemplo el código 0328740 existe 16 registros como observa existe 1 como DIRECTOR y 15 como docente este resultado se necesita.
Libro2
libro 1
2 Respuestas
Macro de avance
Sub Compara_nexus()
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("DOCENTES")
ruta = ThisWorkbook.Path
'CRITERIOS PARA BUSCAR Y CONTAR
Dir1 = "DIRECTOR I.E."
SubDir1 = "SUB-DIRECTOR I.E."
prof = "PROFESOR"
auxed = "AUXILIAR DE EDUCACION"
profuncdir = "PROFESOR (FUNCIONES DE DIRECTOR)"
profaip = "PROFESOR - AIP"
profisica = "PROFESOR - EDUCACION FISICA"
jefelab = "JEFE DE LABORATORIO"
jefetaller = "JEFE DE TALLER"
profcoord = "PROFESOR COORDINADOR"
profCpedag = "COORDINADOR PEDAGOGICO"
coordTOE = "COORDINADOR DE TUTORIA Y ORIENTACION EDUCATIVA"
Application.ScreenUpdating = False
'ABRE EL ARCHIVO
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo de excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivo xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
arch = .SelectedItems.Item(1)
Set l2 = Workbooks.Open(arch)
Set h2 = l2.Sheets(1)
X = h2.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To h2.Range("A" & Rows.Count).End(xlUp).Row
h1.Activate
Application.StatusBar = "Comparando el libro..........: " & l2.Name & " la fila " & i & " de " & X
Set r = h1.Columns("E") ' Código modular
Set b = r.Find(h2.Cells(i, "I"), , xlValues, lookat:=xlWhole)
If Not b Is Nothing Then
Select Case h2.Cells(i, "Q") ' col CARGO
Case Dir1: col = "Q": crit = Dir1
Case SubDir1: col = "R": crit = SubDir1
Case prof: col = "X": crit = prof
Case auxed: col = "AC": crit = auxed
Case profuncdir: col = "AB": crit = profuncdir
Case profaip: col = "Y": crit = profaip
Case profisica: col = "Z": crit = profisica
Case jefelab: col = "V": crit = jefelab
Case jefetaller: col = "W": crit = jefetaller
Case profcoord: col = "AA": crit = profcoord
Case profCpedag: col = "S": crit = profCpedag
Case coordTOE: col = "T": crit = coordTOE
End Select
'CONTAR POR CRITERIO
h1.Cells(b.Row, col) = Application.WorksheetFunction.CountIf(h2.Cells(i, "Q"), crit)
End If
Next i
l2.Close False
Else
MsgBox "PROCESO CANCELADO"
Exit Sub
End If
End With
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Actualización NEXUS Finalizada"
End Sub
Buenos días dante respondiendo a la pregunta
¿Y qué necesitas?
necesito comparar 2 libros por código modular
¿Qué debe hacer la macro en caso de que no exista?
poner cero
¿Qué debe hacer la macro si el código SÍ existe?
si existe el código en la columna "Q" buscar estos criterios y contar .
el resultado se pondrá en el libro1 en las columnas según el criterio
*************CRITERIOS***************** Dir1 = "DIRECTOR I.E." SubDir1 = "SUB-DIRECTOR I.E." prof = "PROFESOR" auxed = "AUXILIAR DE EDUCACION" profuncdir = "PROFESOR (FUNCIONES DE DIRECTOR)" profaip = "PROFESOR - AIP" profisica = "PROFESOR - EDUCACION FISICA" jefelab = "JEFE DE LABORATORIO" jefetaller = "JEFE DE TALLER" profcoord = "PROFESOR COORDINADOR" profCpedag = "COORDINADOR PEDAGOGICO" coordTOE = "COORDINADOR DE TUTORIA Y ORIENTACION EDUCATIVA"
Gracias por el apoyo
agregué esto y me sale error
'CONTAR POR CRITERIO ncell = b.Address Do If Cells(i, "Q") = crit Then h1.Cells(b.Row, col) = Application.WorksheetFunction.CountIf(h2.Cells(i, "Q"), crit) End If Set b = r.FindNext(b) Loop While Not b Is Nothing And b.Address <> ncell
Es complicado seguirte el paso.
En tu primer imagen los encabezados del libro1 aparecen en la fila 3, ahora aparecen en la fila 1.
Los nombres en la hoja del libro 2 tienen un nombre, en tu código tienen otro nombre y en los encabezados tienen otro nombre. Si pudieras homologar los nombres sería más práctico.
Ese nombre ni aparece en los encabezado ni en el código.
Y cuántos registros tienes en cada hoja. Supongo que lo haré con matrices para que se más rápido.
Ah otro detalle, el código estaba en la columna E y ahora aparece en la columna D.
Los valores en la hoja del libro1 al inicio de la macro, están vacías, es decir, el código 16617127-profesores está vacía y según tu ejemplo se llenará con un 7.
O existen valores iniciales y si existe un 4 se le deben sumar 7, ¿el resultado deberá ser 11?
Suponiendo lo siguiente:
- Libro 1, códigos empiezan en D2.
- Libro 2, códigos empiezan en I6
- Puse en un arreglo los nombres ordenados como los tienes en el libro 1.
- Los nombres empiezan en la columna P
Nota: Agrega la parte para abrir el archivo.
Entonces prueba lo siguiente:
Sub compara_codigos()
Dim wb1 As Workbook, wb2 As Workbook
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dic As Object
Dim a As Variant, b As Variant, c As Variant
Dim crit As Variant, arch As Variant
Dim i As Long, fila As Long, col As Variant
'
Application.ScreenUpdating = False
'
crit = Array("DIRECTOR I.E.", _
"SUB-DIRECTOR I.E.", _
"COORDINADOR PEDAGOGICO", _
"COORDINADOR DE TUTORIA Y ORIENTACION EDUCATIVA", _
"COORDINADOR ACADEMICO", _
"JEFE DE LABORATORIO", _
"JEFE DE TALLER", _
"PROFESOR", _
"PROFESOR - AIP", _
"PROFESOR - EDUCACION FISICA", _
"PROFESOR COORDINADOR", _
"PROFESOR (FUNCIONES DE DIRECTOR)", _
"AUXILIAR DE EDUCACION")
'
Set wb1 = ThisWorkbook
Set sh1 = wb1.Sheets("DOCENTES")
arch = "Libro2.xlsx"
Set wb2 = Workbooks.Open(arch)
Set sh2 = wb2.Sheets(1)
Set dic = CreateObject("Scripting.Dictionary")
'Matriz códigos de libro1
a = sh1.Range("D2:D" & sh1.Range("D" & Rows.Count).End(3).Row).Value
'matriz de resultado del libro1
ReDim b(1 To UBound(a, 1), 1 To 13)
'matriz de libro2
c = sh2.Range("I6:Q" & sh2.Range("I" & Rows.Count).End(3).Row).Value
'llenar el índice del libro1
For i = 1 To UBound(a, 1)
dic(a(i, 1)) = i 'número de fila en la matriz
Next
'lee datos del libro2
For i = 1 To UBound(c, 1)
If dic.exists(c(i, 1)) Then
fila = dic(c(i, 1))
col = Application.Match(c(i, 9), crit, 0)
If Not IsError(col) Then
b(fila, col) = b(fila, col) + 1
End If
End If
Next
sh1.Range("P2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
wb1.Activate
End Sub
¡Gracias estimado Dante ! ya te comento que tal me fue
[No olvides valorar
.