Copiar y pegar suma de celdas repetidas

Hola que tal, tengo otro problema, tengo varios archivos con formato similar, en los cuales tengo que ubicar la columna J y colocar su resultado de la columna P en otro archivo en el cual se supone que es el resumen de todos los archivos; en este resumen la primera columna es igual a los datos que pudieran existir en la columna J de los primeros archivos, y cada columna siguiente esta numerada del 1 hasta el 150 aproximadamente que serian los archivos que al principio mencione. Y en cada columna tengo que jalar el resultado del total de la columna P de cada archivo, pero como la columna J puede tener datos repetidos, en el archivo de resumen se debe colocar la suma total de estos de la columna P. Y los primeros archivos tienen celdas que están vacías en la columna J.
Habrá algo con que se pueda realizar esto, gracias y espero me puedas ayudar.

1 respuesta

Respuesta
1
¡Es bastante lo que pides!
Y para resolverlo, se necesita saber:
- El nombre de los 150 archivos
- Número e nombres de las hojas de cada uno de los 150 archivos, desde las que se extraerán los datos.
- Los distintos nombres de todos los elementos existentes en J de todas las hojas. Estos nombres deberían estar listados en la primera columna de la hoja resumen, ya que las próximas 150 columnas (según entiendo) contendrán los totales relacionados a cada archivo y referente a los datos almacenados en J.
Preguntas:
1. ¿Están todos los archivos en la misma carpeta (directorio)?
2. ¿Todos los archivos identifican a la hoja origen con el mismo nombre?
3. ¿Tienes el listado de los elementos de la columna J o hay que extraerlos de los distintos libros?
¡Espero repuesta!
NOTA: Como consejo, intenta dividir tu gran problema en problemas más pequeños. Es complicado disponerse a resolver un problema como el que planteas; aun más, teniendo tan pocos antecedentes.
Mira el archivo de resumen se llama Resumen planos 100.xls, el cual en la columna A tiene todos los posibles datos que pudieran venir en la columna J de los otros 150 archivos, los cuales se llamas 100-1.xls, 100-2.xls así sucesivamente hasta llegar al 150 aproximadamente. Todos los archivos se encuentran en una misma carpeta.
Y los 150 archivos, no contienen mucha información en la columna J, a lo mucho 2 hoja o una en forma vertical y como te digo con varios espacios entre si de las filas.
En la pregunta me equivoque y puse que el resultado estaba en la columna P, pero no es así, esta en la columna R.
No se si me explique, o si quieras que te mande unos archivos de prueba a un correo que me pudieras dar, para que lo veas por tus propios ojos.
Gracias.
Ok, envíame los archivos y la explicación a isenrey(a)yahoo. Es.
Hola ya te envíe los archivos y la explicación, espero te hayan llegado.
Bebes seguir las siguientes instrucciones (las macros están hechas exclusivamente para el problema planteado, pero si quieres modificar a resumen 101, por ejemplo, no es muy complicado)
Instrucciones:
1.- Todas las macros las pegas en el mismo módulo en el libro resumen.
2. Debes poner un botón en la hoja resumen que apunte a la siguiente macro
Sub calcular()
    Dim fila() As Boolean
    Dim libro As Workbook
    Dim archivos() As String
    Dim ruta As String
    Dim colDes As Integer
    Dim nFilas As Double
    Dim hoja As Worksheet
    Dim filaDes As Double
    ruta = ThisWorkbook.Path
    archivos = fcnBuscarArch(ruta, "
100*.xls") 'Pibros a buscar
    'Recorrer cada archivo
    For i = 1 To UBound(archivos)
        colDes = fcnExtNum(archivos(i)) + 5 '
Considera que el primer archivo va a la columna F

        DoEvents
        Set libro = Workbooks.Open(ruta & "/" & archivos(i))
        Set hoja = libro.Sheets("
Hoja1") 'Hoja destino
        nFilas = hoja.Range("
J65536").End(xlUp).Row
        ReDim fila(nFilas)
        For j = 6 To nFilas
            If Not fila(j) Then
                filaDes = buscaEnCol(
Hoja1, "A", hoja.Range("J" & j))
                Workbooks(ruta & "/
resumen planos 100.xls").Sheets("Hoja1").Cells(filaDes, colDes) = sumarTodoEnCol(hoja, "J", "R", hoja.Range("J" & j), fila)
'resumen planos 100.xls: libro destino, está en la misma ruta que los demas libros
'J y R: Columnas de busqueda y extracción de valores, respectivamente
            End If
        Next
        'MsgBox fcnExtNum(ar(i))
        libro.Close
    Next
End Sub

Para cualquier tipo de configuración, la única macro que tienes que tocar es la macro calcular. Familiarizate con cada uno de los elementos que están subrayados e intenta reconocerlos por si en algún momento quieres hacer algún cambio (Puedes adaptar su funcionalidad a cualquier colección de libros que cumplan con las características de la colección que en este momento manejas, o sea, que los libros tengan nombres del tipo: NOMBRE-NUMERO.xls).
------------------------------------------------
Demás macros que debes poner en el módulo
'Extrae el numero del archivo (si es 100-39.xls, extrae 39. el punto y el guión son fundamentales para que extraiga el número, ya que los considera como delimitadores)
Function fcnExtNum(nombreArch As String) As String
    fcnExtNum = Mid(nombreArch, _
                    InStr(1, nombreArch, "-") + 1, _
                    InStr(1, nombreArch, ".") - _
                    InStr(1, nombreArch, "-") - 1)
End Function

'BUSCAR ARCHIVOS EN UN DIRECTORIO
Function fcnBuscarArch(sPath As String, strArch As String) As String()
    Dim res() As String
    Dim sName As String
    Dim sFullName As String
    Dim Dirs() As String
    Dim DirsNo As Integer
    Dim i As Integer
    If Not Right(sPath, 1) = "\" Then
        sPath = sPath & "\"
    End If
    DirsNo = 0
    'On Error Resume Next
    sName = Dir(sPath, vbDirectory)
    If Err.Number <> 0 Then
        Exit Function
    End If
    ReDim Preserve res(0)
    While Len(sName) > 0
        If LCase(sName) Like strArch Then
            ReDim Preserve res(UBound(res) + 1)
            res(UBound(res)) = sName
        End If
        sName = Dir
    Wend
    fcnBuscarArch = res
End Function

'SUMA TODOS LOS ELEMENTOS EN UNA COLUMNA QUE COINCIDAN CON EL CRITERIO
Function sumarTodoEnCol(hojaBusq As Worksheet, _
                    strColBusq As String, _
                    strColVal As String, _
                    strValor As String, _
                    ByRef blnMarca() As Boolean) As Double
    Dim dblFilaIni As Double
    Dim blnFin As Boolean
    Dim resulta As Range
    Dim dblTotal As Double
    If strValor = "" Then Exit Function
    Set resulta = hojaBusq.Range(strColBusq & ":" & strColBusq).Find(strValor, _
                                hojaBusq.Range(strColBusq & "65536").End(xlUp), _
                                LookIn:=xlValues, LookAt:=xlWhole)
    dblFilaIni = resulta.Row
    dblTotal = 0
    Do Until (resulta Is Nothing Or blnFin)
        blnMarca(resulta.Row) = True
        dblTotal = dblTotal + hojaBusq.Range(strColVal & resulta.Row).Value
        Set resulta = hojaBusq.Range(strColBusq & ":" & strColBusq).FindNext(resulta)
        blnFin = (resulta.Row <= dblFilaIni)
    Loop
    sumarTodoEnCol = dblTotal
End Function
'BUSCAR EN UNA COLUMNA
Function buscaEnCol(hojaBusq As Worksheet, _
                    strCol As String, _
                    strValor As String) As Double
    Dim resulta As Range
    Set resulta = hojaBusq.Range(strCol & ":" & strCol).Find(strValor, _
                                hojaBusq.Range(strCol & "65536").End(xlUp), _
                                LookIn:=xlValues, LookAt:=xlWhole)
    If (Not resulta Is Nothing) Then
        buscaEnCol = resulta.Row
    End If
End Function
En calcular en la línea
Workbooks(ruta & "/resumen planos 100.xls").Sheets("Hoja1").Cells(filaDes, colDes) = sumarTodoEnCol(hoja, "J", "R", hoja.Range("J" & j), fila)
debes eliminar lo que marco en negro y debes dejarlo de esta forma
Workbooks("resumen planos 100.xls").Sheets("Hoja1").Cells(filaDes, colDes) = sumarTodoEnCol(hoja, "J", "R", hoja.Range("J" & j), fila)
Hola que tal, hice la prueba con los archivos que te envíe, y salio correcta la macro, pero cuando trate de hacela con más archivos me marca error "Subíndice fuera de intervalo"
¿En qui línea te marca ese error?
Para saberlo, tienes que presionar depurar, en el mensaje que te aparece... y observa qué valor tienen las variables al momento ue ocurre el error. Eso lo puedes hacer poniendo el mouse sobre las variables!
En el mensaje solo aparece ACEPTAR y CANCELAR, no aparece depurar, pero creo que ya se por que es el error, te mande un correo con uno de los archivos nuevos que intente usar.
Trate de corregir yo misma la macro, pero vas a decir que soy una tonta, pero no pude, y mejor te mande el archivo.
Gracias.
En la macro "calcular" siempre se asume que el nombre de la hoja de la que sacas los datos se llama "Hoja1", en el nuevo archivo que incorporaste, no se llama "Hoja1" se llama "O.C.", por tanto, define bien el nombre de la hoja que contendrá los datos, una vez que lo hagas bueca esta línea en la macro "calcular"
Set hoja = libro.Sheets("Hoja1") 'Hoja destino
Y cambia el nombre de "Hoja1" al nombre definitivo. Recuerda que en todos los libros, la hoja debe tener el midmo nombre.
Hola buenos días.
Ya le cambie la instrucción que mencionas, por que toda la información de los archivos vienen de la hoja "O.C."; pero ahora, cuando corro la macro aparece un mensaje por cada archivo que procesa de "Desea guardar los cambios efectuados en el archivo ***.xls ? SI, NO, CANCELAR. Ya no lo cierra en automático los archivos de excel que abre la macro.
En calcular, cambia la inctrucción
Libro. Close
Por
Libro. Close xlDoNotSaveChanges 'si no quieres salvar cambios
o
Libro. Close xlSaveChanges 'si quieres guardar cambios
Tendría que funcionar
PERFECTO, eres un genio, mil gracias acabas de salvarme la vida.
Una ultima pregunta, me podrías recomendar un buen libro sobre macros, para que me ponga a estudiar y ya pueda yo crear mis propias macros.
Acabo de procesar un archivo 100-48 que esta muy grande, por que ya ves que los archivos que te mande eran de una sola hoja; pero este tiene 8 hojas y cuando llega a este archivo se detiene la macro y solo aparece un recuadro que tiene un tache y 400 y solo tiene ACEPTAR y AYUDA, y al correr la macro paso a paso se detiene en la parte final de la Función sumar.
Con lo de libros, yo, antes de trabajar en Excel, aprendí visual basic, y lo de las macros me sale por default :). No te podría recomendar un libro es pecífico para macros, ya que yo partí con "Aprendiendo Visual Basic 6.0 en 21 Días" y de ahíl la red ha sido vital.
Con respecto a tu error, tenía la duda de qué pasaría si abrías un archivo muy grande, y el posible error es que no alcanza a leer los datos antes de cerrar el archivo.
Enviame ese archivo para corroborarlo.
El problema no tenía que ver con el tamaño del archivo, sino con algunos perfiles que están en las hojas que no están en el resumen.
Si es solamente eso, cambia tu procedimiento calcular por este:
Sub calcular()
    Dim fila() As Boolean
    Dim libro As Workbook
    Dim archivos() As String
    Dim errores(), error As Integer
    Dim ruta As String
    Dim colDes As Integer
    Dim nFilas As Double
    Dim hoja As Worksheet
    Dim filaDes As Double
    ruta = ThisWorkbook.Path
    archivos = fcnBuscarArch(ruta, "100*.xls")
    error = -1
    'Recorrer cada archivo
    For i = 1 To UBound(archivos)
        colDes = fcnExtNum(archivos(i)) + 5
        DoEvents
        Set libro = Workbooks.Open(ruta & "/" & archivos(i))
        Set hoja = libro.Sheets("O.C.")
        nFilas = hoja.Range("J65536").End(xlUp).Row
        ReDim fila(nFilas)
        For j = 6 To nFilas
            If Not fila(j) Then
                filaDes = buscaEnCol(Hoja1, "A", hoja.Range("J" & j))
                If filaDes > 0 Then
                    Workbooks("resumen planos 100.xls").Sheets("Hoja1").Cells(filaDes, colDes) = sumarTodoEnCol(hoja, "J", "R", hoja.Range("J" & j), fila)
                Else
                    error = error + 1
                    ReDim Preserve errores(error)
                    errores(error) = Array(libro.Name, hoja.Range("J" & j).Value, _
                                     sumarTodoEnCol(hoja, "J", "R", hoja.Range("J" & j), fila))
                End If
            End If
        Next
        'MsgBox fcnExtNum(ar(i))
        libro.Close xlDoNotSaveChanges
    Next
    'SECCION PARA GENERAR INFORME DE ERROR
    If error >= 0 Then
        If MsgBox("Hay perfiles que no fueron encontrados en el resumen" & vbNewLine _
                  & "¿Desea crear una planilla con los errores?", _
                  vbYesNo + vbQuestion, "Hay errores") Then
            Dim libErr As Workbook
            Dim hojaErr As Worksheet
            Set libErr = Workbooks.Add
            Set hojaErr = libErr.Sheets(1)
            hojaErr.Name = "Perfiles Faltantes"
            hojaErr.[A1] = "Libro"
            hojaErr.[B1] = "Perfil"
            hojaErr.[C1] = "Total"
            For i = 0 To error
                hojaErr.Range("A" & (i + 2)).Value = errores(i)(0)
                hojaErr.Range("B" & (i + 2)).Value = errores(i)(1)
                hojaErr.Range("C" & (i + 2)).Value = errores(i)(2)
            Next
            Columns("A:C").EntireColumn.AutoFit
            libErr.Activate
            Set libErr = Nothing
            Set hojaErr = Nothing
        Else
            MsgBox "Los errores fueron ignorados", vbOKOnly, "Errores ignorados"
        End If
    End If
    'FIN SECCION INFORME DE ERROR
End Sub

----------------
La solución era mucho más simple que todo lo que puse aquí, pero consideré que te sería útil generar un informe de errores.
Un pequeño detalle:
El if que solicita autorización para crear el informe de errores debe quedar así:
If MsgBox("Hay perfiles que no fueron encontrados en el resumen" & vbNewLine _
                  & "¿Desea crear una planilla con los errores?", _
                  vbYesNo + vbQuestion, "Hay errores") = vbYes Then
En el código anterior me había faltado el vbYes.
Hola, esta genial la modificación, muchísimas gracias. Puedo finalizar esta pregunta y si aparecen otros detalles con otros archivos (que espero que no), ¿te podría mandar un email? ; O ya te desespere con tanta pregunta.
Siempre es un agrado poder ayudar!
Teniendo tiempo, te respondo sin problemas.
Aunque, aparte de enviarme el mail, te recomiendo que pongas tu inquietud en el tablón de todoexpertos, con un titulo descriptivo, ya que la solución a tus dudas puede ser la solución a las dudas de otras personas también.
Ese es el motivo porque cada pregunta debería ser un post aparte.
Aunque esté no disponible en todoexpertos, siempre me puedo hacer un tiempo.
Ya tienes mi e-mail!

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas