Attribute VB_Name = "modDesgloseFilasPorClave"
Option Explicit

' =====================================================================
'  modDesgloseFilasPorClave - Sustituir cada fila "resumen" por sus
'  lineas de "detalle", emparejadas por una clave y un importe.
'
'  QUE HACE
'    Caso tipico: una hoja RESUMEN con una fila por articulo, pedido,
'    albaran, proyecto... (clave + importe total) y una hoja DETALLE con
'    varias lineas por esa misma clave (componentes, partidas, conceptos),
'    en cualquier orden. La macro localiza en RESUMEN la fila cuyo importe
'    coincide con la suma de sus lineas de DETALLE (con tolerancia),
'    inserta debajo una copia por cada linea con los campos de detalle que
'    indiques, y elimina la fila resumen original. Las filas nuevas quedan
'    en verde, la hoja conserva el orden y lo que no cuadra NO se toca:
'    queda anotado en la hoja Desglose_Log con el motivo.
'
'  COMO USARLA
'    1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar).
'    2. Rellena la hoja "Config" con las claves de abajo.
'    3. Ejecuta DesglosarFilasPorClave (Alt+F8). Trabaja sobre la hoja
'       resumen del propio libro: guarda una copia antes o usa Deshacer.
'
'  PARA ADAPTARLA  (busca ">> ADAPTAR")
'    - Color de las filas nuevas (COLOR_FILA_NUEVA).
'    - Emparejar sin comprobar el importe (solo por clave).
'    - Conservar la fila resumen en vez de eliminarla.
'
'  Configuracion (hoja "Config", columna A clave / columna B valor):
'    HojaResumen         Nombre de la hoja resumen            (ej. Resumen)
'    HojaDetalle         Nombre de la hoja detalle            (ej. Detalle)
'    ClaveResumen        Columna de la clave en resumen       (ej. B)
'    ClaveDetalle        Columna de la clave en detalle       (ej. B)
'    SubgrupoDetalle     Columna que separa subgrupos dentro de una
'                        misma clave (opcional, ej. A). Cada subgrupo se
'                        empareja con una fila resumen distinta.
'    ImporteResumen      Columna del importe en resumen       (ej. K)
'    ImporteDetalle      Columna del importe en detalle       (ej. F)
'    Tolerancia          Diferencia admitida entre importe y suma (0,2)
'    CamposDetalle       Que columnas de detalle van a que columnas de
'                        resumen, separadas por coma: "F>K,G>R,C>P"
'                        (detalle>resumen). Si una pareja termina en "!"
'                        (ej. "C>P!") el valor se traduce con la hoja
'                        Tabla (columna A codigo, columna B texto).
'    ColumnaEtiqueta     Columna de resumen donde escribir la etiqueta
'                        del grupo (opcional, ej. Q)
'    TextoEtiqueta       Texto de la etiqueta; {n} = numero de subgrupo
'                        (ej. "Linea {n} del desglose")
'  Requiere: modUtilidades.
' =====================================================================

' >> ADAPTAR: color de las filas insertadas (verde claro de Excel). 0 = sin color.
Private Const COLOR_FILA_NUEVA As Long = 13561798 ' RGB(198,239,206)

Private Type Pareja
    ColDetalle As Long
    ColResumen As Long
    Traducir As Boolean
End Type

Public Sub DesglosarFilasPorClave()
    Dim wsRes As Worksheet, wsDet As Worksheet, wsLog As Worksheet, est As EstadoExcel
    Dim cClaveRes As Long, cClaveDet As Long, cSub As Long, cImpRes As Long, cImpDet As Long, cEtiq As Long
    Dim tolerancia As Double, textoEtiqueta As String, parejas() As Pareja, nParejas As Long, tabla As Object
    Dim ultRes As Long, ultDet As Long, maxColDet As Long, maxColRes As Long
    Dim det As Variant, res As Variant, i As Long, j As Long, n As Long, r As Long
    Dim grupos As Object, ordenGrupos As Collection, numSub As Object, subDict As Object
    Dim indiceRes As Object, filaTomada As Object, plan As Object, filasPlan() As Long
    Dim cg As Variant, partes() As String, k As String, sub1 As String, suma As Double
    Dim filaCoincidente As Long, fila As Variant, detFilas As Collection, logFilas As Collection
    Dim desglosados As Long, noEncontrados As Long, filasNuevas As Long, v As Variant, msg As String

    On Error GoTo Fallo
    ' ---- Configuracion ----
    Set wsRes = ThisWorkbook.Worksheets(LeerConfig("HojaResumen"))
    Set wsDet = ThisWorkbook.Worksheets(LeerConfig("HojaDetalle"))
    cClaveRes = ColumnaANumero(LeerConfig("ClaveResumen"))
    cClaveDet = ColumnaANumero(LeerConfig("ClaveDetalle"))
    If Len(LeerConfig("SubgrupoDetalle", False)) > 0 Then cSub = ColumnaANumero(LeerConfig("SubgrupoDetalle", False))
    cImpRes = ColumnaANumero(LeerConfig("ImporteResumen"))
    cImpDet = ColumnaANumero(LeerConfig("ImporteDetalle"))
    If Len(LeerConfig("ColumnaEtiqueta", False)) > 0 Then cEtiq = ColumnaANumero(LeerConfig("ColumnaEtiqueta", False))
    textoEtiqueta = LeerConfig("TextoEtiqueta", False, "Linea {n} del desglose")
    tolerancia = Val(Replace(LeerConfig("Tolerancia", False, "0.2"), ",", "."))
    If tolerancia < 0 Then tolerancia = 0
    nParejas = LeerParejas(LeerConfig("CamposDetalle"), parejas)
    For j = 1 To nParejas
        If parejas(j).Traducir And tabla Is Nothing Then Set tabla = CargarTabla()
    Next j

    ultRes = UltimaFila(wsRes, cClaveRes)
    ultDet = UltimaFila(wsDet, cClaveDet)
    If ultRes < 2 Or ultDet < 2 Then Err.Raise vbObjectError + 400, , "No hay datos en resumen o detalle."
    maxColDet = Maximo(cClaveDet, cSub, cImpDet)
    maxColRes = Maximo(cClaveRes, cImpRes, 1)
    For j = 1 To nParejas
        If parejas(j).ColDetalle > maxColDet Then maxColDet = parejas(j).ColDetalle
    Next j
    det = wsDet.Range(wsDet.Cells(2, 1), wsDet.Cells(ultDet, maxColDet)).Value
    res = wsRes.Range(wsRes.Cells(2, 1), wsRes.Cells(ultRes, maxColRes)).Value

    ' ---- 1) Agrupar detalle por clave (+ subgrupo), en orden de aparicion ----
    Set grupos = CreateObject("Scripting.Dictionary"): Set ordenGrupos = New Collection
    Set numSub = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(det, 1)
        k = Clave(det(i, cClaveDet))
        If Len(k) > 0 Then
            If cSub > 0 Then sub1 = Clave(det(i, cSub)) Else sub1 = "1"
            If Len(sub1) > 0 Then
                cg = k & vbNullChar & sub1
                If Not grupos.Exists(cg) Then
                    grupos.Add cg, New Collection
                    ordenGrupos.Add cg
                    If Not numSub.Exists(k) Then numSub.Add k, CreateObject("Scripting.Dictionary")
                    Set subDict = numSub(k)
                    subDict.Add sub1, subDict.Count + 1
                End If
                grupos(cg).Add i
            End If
        End If
    Next i

    ' ---- 2) Indice del resumen por clave ----
    Set indiceRes = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(res, 1)
        k = Clave(res(i, cClaveRes))
        If Len(k) > 0 Then
            If Not indiceRes.Exists(k) Then indiceRes.Add k, New Collection
            indiceRes(k).Add i + 1
        End If
    Next i

    ' ---- 3) Emparejar cada grupo con una fila resumen libre de igual clave e importe ----
    Set filaTomada = CreateObject("Scripting.Dictionary"): Set plan = CreateObject("Scripting.Dictionary")
    Set logFilas = New Collection
    For Each cg In ordenGrupos
        partes = Split(cg, vbNullChar): k = partes(0): sub1 = partes(1)
        suma = 0
        For Each fila In grupos(cg)
            suma = suma + Numero(det(fila, cImpDet))
        Next fila
        filaCoincidente = 0
        If indiceRes.Exists(k) Then
            For Each fila In indiceRes(k)
                If Not filaTomada.Exists(fila) Then
                    ' >> ADAPTAR: criterio de emparejamiento. Ahora: misma clave e importe igual a la
                    '    suma de las lineas (+/- Tolerancia). Para emparejar solo por clave (la primera
                    '    fila libre con esa clave) sustituye la condicion por:  If True Then
                    If Abs(Numero(res(fila - 1, cImpRes)) - suma) <= tolerancia Then filaCoincidente = fila: Exit For
                End If
            Next fila
        End If
        If filaCoincidente > 0 Then
            filaTomada.Add filaCoincidente, True
            plan.Add filaCoincidente, Array(cg, numSub(k)(sub1))
            desglosados = desglosados + 1
        Else
            noEncontrados = noEncontrados + 1
            logFilas.Add Array(k, sub1, suma, "Sin fila resumen con esa clave e importe (+/- " & tolerancia & ")")
        End If
    Next cg

    If plan.Count = 0 Then
        EscribirLog wsLog, logFilas, 0, noEncontrados, 0
        Aviso "Ninguna coincidencia. Revisa la hoja Desglose_Log.", vbExclamation
        Exit Sub
    End If

    ' ---- 4) Ejecutar de abajo arriba para no desplazar filas pendientes ----
    GuardarEstado est
    ReDim filasPlan(1 To plan.Count): i = 0
    For Each fila In plan.Keys
        i = i + 1: filasPlan(i) = fila
    Next fila
    OrdenarDescendente filasPlan
    For i = 1 To UBound(filasPlan)
        r = filasPlan(i)
        Set detFilas = grupos(plan(r)(0))
        n = detFilas.Count
        wsRes.Rows(r + 1).Resize(n).Insert Shift:=xlDown
        wsRes.Rows(r).Copy wsRes.Rows(r + 1).Resize(n)
        For Each fila In detFilas
            r = r + 1
            For j = 1 To nParejas
                v = det(fila, parejas(j).ColDetalle)
                If IsError(v) Then v = ""
                If parejas(j).Traducir Then v = Traducir(tabla, v)
                wsRes.Cells(r, parejas(j).ColResumen).Value = v
            Next j
            If cEtiq > 0 Then wsRes.Cells(r, cEtiq).Value = Replace(textoEtiqueta, "{n}", CStr(plan(filasPlan(i))(1)))
            wsRes.Rows(r).Interior.Color = COLOR_FILA_NUEVA
            filasNuevas = filasNuevas + 1
        Next fila
        ' >> ADAPTAR: para conservar la fila resumen como cabecera del grupo (en vez de
        '    eliminarla), comenta la linea siguiente.
        wsRes.Rows(filasPlan(i)).Delete
        Progreso "Desglosando", i, UBound(filasPlan)
    Next i
    Application.CutCopyMode = False
    RestaurarEstado est

    EscribirLog wsLog, logFilas, desglosados, noEncontrados, filasNuevas
    msg = "Desglose completado." & vbCrLf & "Filas resumen desglosadas: " & desglosados & vbCrLf & _
          "Filas nuevas (verdes): " & filasNuevas & vbCrLf & "Grupos sin coincidencia: " & noEncontrados
    If noEncontrados > 0 Then msg = msg & vbCrLf & "Detalle en la hoja Desglose_Log."
    Aviso msg, vbInformation
    Exit Sub
Fallo:
    Application.CutCopyMode = False
    RestaurarEstado est
    Aviso "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
           "La hoja puede haber quedado a medias: cierra sin guardar o usa Deshacer.", vbExclamation
End Sub

' "F>K,G>R,C>P!" -> parejas detalle>resumen; "!" = traducir con la hoja Tabla
Private Function LeerParejas(ByVal texto As String, ByRef parejas() As Pareja) As Long
    Dim trozos() As String, i As Long, lados() As String, n As Long
    trozos = Split(texto, ",")
    ReDim parejas(1 To UBound(trozos) + 1)
    For i = LBound(trozos) To UBound(trozos)
        lados = Split(Trim$(trozos(i)), ">")
        If UBound(lados) <> 1 Then Err.Raise vbObjectError + 401, , "CamposDetalle: pareja no valida '" & trozos(i) & "'. Formato: F>K"
        n = n + 1
        parejas(n).ColDetalle = ColumnaANumero(Trim$(lados(0)))
        parejas(n).Traducir = (Right$(Trim$(lados(1)), 1) = "!")
        parejas(n).ColResumen = ColumnaANumero(Replace(Trim$(lados(1)), "!", ""))
    Next i
    If n = 0 Then Err.Raise vbObjectError + 402, , "CamposDetalle esta vacio."
    LeerParejas = n
End Function

' Hoja "Tabla": columna A codigo, columna B texto. Varias columnas de
' codigo se admiten concatenadas (ej. "01" & "02" en A).
Private Function CargarTabla() As Object
    Dim ws As Worksheet, d As Object, datos As Variant, i As Long, ult As Long
    Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = vbTextCompare
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(LeerConfig("HojaTabla", False, "Tabla"))
    On Error GoTo 0
    If ws Is Nothing Then Err.Raise vbObjectError + 403, , "Falta la hoja Tabla (codigo en A, texto en B) para traducir valores."
    ult = UltimaFila(ws, 1)
    If ult >= 1 Then
        datos = ws.Range("A1:B" & ult).Value
        For i = 1 To ult
            If Not IsError(datos(i, 1)) Then
                If Len(Trim$(CStr(datos(i, 1) & ""))) > 0 And Not d.Exists(Trim$(CStr(datos(i, 1)))) Then d.Add Trim$(CStr(datos(i, 1))), datos(i, 2)
            End If
        Next i
    End If
    Set CargarTabla = d
End Function

Private Function Traducir(ByVal tabla As Object, ByVal v As Variant) As Variant
    Dim k As String
    If IsError(v) Then v = ""
    k = Trim$(CStr(v & ""))
    If tabla.Exists(k) Then Traducir = tabla(k) Else Traducir = "NO DEFINIDO (" & k & ")"
End Function

Private Function Clave(ByVal v As Variant) As String
    If IsError(v) Then v = ""
    Clave = Trim$(CStr(v & ""))
    If IsNumeric(Clave) And Len(Clave) > 0 Then Clave = CStr(CDbl(Clave)) ' "007" y 7 son la misma clave
End Function

Private Function Numero(ByVal v As Variant) As Double
    Dim s As String
    If IsError(v) Then v = ""
    If IsNumeric(v) And VarType(v) <> vbString Then
        Numero = CDbl(v)
    Else
        s = Replace(Trim$(CStr(v & "")), ",", ".")
        If IsNumeric(s) Then Numero = Val(s)
    End If
End Function

Private Function Maximo(ByVal a As Long, ByVal b As Long, ByVal c As Long) As Long
    Maximo = a
    If b > Maximo Then Maximo = b
    If c > Maximo Then Maximo = c
End Function

Private Sub OrdenarDescendente(ByRef a() As Long)
    Dim i As Long, j As Long, t As Long
    For i = LBound(a) To UBound(a) - 1
        For j = i + 1 To UBound(a)
            If a(j) > a(i) Then t = a(i): a(i) = a(j): a(j) = t
        Next j
    Next i
End Sub

Private Sub EscribirLog(ByRef wsLog As Worksheet, ByVal filas As Collection, ByVal desglosados As Long, _
                        ByVal noEncontrados As Long, ByVal filasNuevas As Long)
    Dim i As Long, f As Variant
    On Error Resume Next
    Set wsLog = ThisWorkbook.Worksheets("Desglose_Log")
    On Error GoTo 0
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsLog.Name = "Desglose_Log"
    End If
    wsLog.Cells.Clear
    wsLog.Range("A1:D1").Value = Array("Clave", "Subgrupo", "Suma detalle", "Motivo")
    wsLog.Range("A1:D1").Font.Bold = True
    i = 1
    For Each f In filas
        i = i + 1
        wsLog.Cells(i, 1).Resize(1, 4).Value = f
    Next f
    i = i + 2
    wsLog.Cells(i, 1).Value = "Ejecutado": wsLog.Cells(i, 2).Value = Format$(Now, "yyyy-mm-dd hh:nn")
    wsLog.Cells(i + 1, 1).Value = "Filas resumen desglosadas": wsLog.Cells(i + 1, 2).Value = desglosados
    wsLog.Cells(i + 2, 1).Value = "Filas nuevas": wsLog.Cells(i + 2, 2).Value = filasNuevas
    wsLog.Cells(i + 3, 1).Value = "Grupos sin coincidencia": wsLog.Cells(i + 3, 2).Value = noEncontrados
    wsLog.Columns("A:D").AutoFit
End Sub