Copiar y pegar de acuerdo a una condición
Tengo un filtro en una hoja, en donde los datos van modificándose de acuerdo a una celda en especifico.
Lo que quiero es que cada que se haga una consulta, copie y pegue los datos en una hoja aparte, pero que cada dato vaya pegándose en las columnas subsecuentes:
Hoja1
a1= 3214 b1= 2 c1= 345
entonces si a1=3214, en una hoja2 pegue
a2=3214 b2=2 c2=345
ahora, en hoja1 hacemos modificaciones
a1=3121 b1=3 c1= 213
en hoja dos pegue
a3=3214 b3=3 c3=213
entonces en hoja dos ya tendremos :
a2=3214 b2=2 c2=345
a3=3214 b3=3 c3=213
Y asi subsecuentemente
1 Respuesta
Respuesta de Dante Amor
1
H o l a:
te anexo la macro actualizada
Sub SumarHoras()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("datos")
Set h2 = Sheets("bitacora")
Set h3 = Sheets("filtro")
Set h4 = Sheets("Acumulado")
'
u = h2.Range("I" & Rows.Count).End(xlUp).Row
If u < 6 Then u = 6
h2.Range("I6:O" & u).ClearContents
h3.Columns("C:Z").ClearContents
ruta = h2.[B6]
una = True
u = h1.Range("C" & Rows.Count).End(xlUp).Row
h1.Range("C3:U" & u).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=h3.Range("A1:A2"), CopyToRange:=h3.Range("C3"), Unique:=False
'
ant = h3.[K4]
If ant = "" Then
MsgBox "No hay registros"
Exit Sub
End If
'
j = 6
h2.Cells(j, "I") = h3.[K4]
h2.Cells(j, "J") = h3.[F4]
For i = 4 To h3.Range("C" & Rows.Count).End(xlUp).Row + 1
If ant <> h3.Cells(i, "K") Then
h2.Cells(j, "K") = h3.Cells(i - 1, "F")
h2.Cells(j, "L") = h2.Cells(j, "K") - h2.Cells(j, "J")
j = j + 1
h2.Cells(j, "I") = h3.Cells(i, "K")
h2.Cells(j, "J") = h3.Cells(i, "F")
End If
ant = h3.Cells(i, "K")
Next
'
n = 0
wtot = 0
For i = 6 To h2.Range("I" & Rows.Count).End(xlUp).Row
Set b = h2.Columns("N").Find(h2.Cells(i, "I"), lookat:=xlWhole)
If Not b Is Nothing Then
h2.Cells(b.Row, "O") = h2.Cells(b.Row, "O") + h2.Cells(i, "L")
Else
u = h2.Range("N" & Rows.Count).End(xlUp).Row + 1
h2.Cells(u, "N") = h2.Cells(i, "I")
h2.Cells(u, "O") = h2.Cells(i, "L")
n = n + 1
End If
wtot = wtot + h2.Cells(i, "L")
Next
h2.[C6] = n
h2.[F6] = wtot
u = h4.Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Range("B6:F6").Copy
h4.Cells(u, "A").PasteSpecial xlValues
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Filtro terminado", vbInformation, "CALCULAR TIEMPOS"
End Subsal u dos
