Como crear una macro para que copie los datos de una celda a otra con datos coincidentes
Necesito de su valioso conocimiento, necesito crear una macro para copiar los datos del primer rango al segundo siempre y cuando coincidan con ese valor. Ejemplo:
Tienen que coincidir los datos de las flechas azules y se tiene que copiar lo de las flechas rojas.
En caso de que sean más registros del rango A que el rango E, se tiene que agregar otro renglón para que se pase la información completa del A al E. De antemano se los agradezco mucho.
Saludos
Respuesta de Dante Amor
1
Te anexo la macro, al final ordena la información para que los códigos queden juntos.
Sub FolioPredio()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.StatusBar = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set l2 = Workbooks("tablaori.xlsx")
Set h2 = l2.Sheets(1)
'
u2 = h2.Range("B" & Rows.Count).End(xlUp).Row
h2.Range("B30:B" & u2).ClearContents
u = h1.Range("C" & Rows.Count).End(xlUp).Row
'
For i = 5 To 100 'u
Application.StatusBar = "Procesando fila: " & i & " de: " & u
folio = h1.Cells(i, "C")
Set r = h2.Columns("A")
Set b = r.Find(folio, lookat:=xlWhole)
existe = False
If Not b Is Nothing Then
ncell = b.Address
'fila = b.Row
Do
'detalle
If b.Offset(0, 1) = "" Then
b.Offset(0, 1) = h1.Cells(i, "D")
existe = True
Exit Do
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
If existe = False Then
Set b = h2.Columns("A").Find("TOTAL", lookat:=xlPart)
If Not b Is Nothing Then
h2.Rows(b.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
h2.Cells(b.Row - 1, "A") = folio
h2.Cells(b.Row - 1, "B") = h1.Cells(i, "D")
h2.Cells(b.Row - 1, "C") = h1.Cells(i, "B")
End If
End If
Next
'
Set b = h2.Columns("A").Find("TOTAL", lookat:=xlPart)
If Not b Is Nothing Then
f = b.Row - 1
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Range("C30:C" & f)
.SortFields.Add Key:=h2.Range("D30:D" & f)
.SortFields.Add Key:=h2.Range("E30:E" & f)
.SetRange h2.Range("A30:Y" & f)
.Header = xlGuess: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
End If
Application.StatusBar = False
MsgBox "Fin"
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
