Macro que suma de acuerdo a color
Que tal espero me puedan ayudar, tengo una macro que suma los valores de acuerdo al color que tengan en la hoja "cheques no cobrados", pero no copia los valores cuando estos están en la columna D, los que están en la columna E si los copia y suma
Adjunto la macro
Sub Colores()
Dim Hoja As Worksheet
Dim R As Range, C As Range
Dim D&
Dim M
Application.ScreenUpdating = 0
ReDim M(1 To 4, 1 To 1)
For Each Hoja In Worksheets
With Hoja
If Hoja.Name <> "Cheques no cobrados" Then
uf = .Range("B" & Rows.Count).End(xlUp).Row
Set R = .Range("B11:B" & uf)
For Each C In R
If C.Interior.ColorIndex = Sheets("Cheques no cobrados").Range("E3").Interior.ColorIndex Then
D = D + 1
ReDim Preserve M(1 To 4, 1 To D)
M(1, D) = .Range("A" & C.Row)
M(2, D) = .Range("B" & C.Row)
M(3, D) = .Range("C" & C.Row)
M(4, D) = .Range("E" & C.Row)
End If
Next C
End If
End With
Next Hoja
If D = 0 Then
MsgBox "No hay Registros con ese color", , "No hay Registros"
Else
With Sheets("cheques no cobrados")
.Range("B7").CurrentRegion.Offset(1).Clear
.Range("B7").Resize(D, 4) = Application.Transpose(M)
.Range("E7", .Range("E" & Rows.Count).End(xlUp)).NumberFormat = "0.00"
.Range("B7").Offset(D, 3).Formula = "=SUM(E7:E" & D + 6 & ")"
.Range("B7").Offset(D, 3).Font.Bold = True
End With
End If
Set C = Nothing
Set R = Nothing
Erase M
Application.ScreenUpdating = 1
End Sub
Respuesta de Elsa Matilde
1
Como los valores siempre estarán en col D o en col E debes evaluar esta situación antes de enviar el importe a la matriz. Es decir que si D no está vacío se guarda ese valor sino se guarda el de la col E.
El código para esa sección de macro quedaría así:
D = D + 1
ReDim Preserve M(1 To 4, 1 To D)
M(1, D) = .Range("A" & C.Row)
M(2, D) = .Range("B" & C.Row)
M(3, D) = .Range("C" & C.Row)
'se controla si el valor está en col D o E
If .Range("D" & C.Row) <> "" Then
M(4, D) = .Range("D" & C.Row)
Else
M(4, D) = .Range("E" & C.Row)
End IfSdos y no olvides valorar la respuesta.
Elsa
http://aplicaexcel.galeon.com/macros.htm
