Macro para revisar que se copien la información con datos
Hola amigos:
Necesito una macro para revisar que se copie una información con datos.
Para esto, tenemos la siguiente macro, donde se copia, transpone, concatena, y ordena:
Sub Datos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("OC")
Set h2 = Sheets("oferta_de_compra")
'
u = h2.Range("E" & Rows.Count).End(xlUp).Row
If u = 2 Then u = 3
h2.Range("A3:M" & u).ClearContents
'
n = 0
ren = 1
For i = 3 To h1.Range("E" & Rows.Count).End(xlUp).Row
For j = Columns("E").Column To Columns("V").Column
If h1.Cells(i, j) <> "" Then
h1.Cells(i, j).Copy
u2 = h2.Range("E" & Rows.Count).End(xlUp).Row + 1
h2.Cells(u2, "E").PasteSpecial Paste:=xlPasteValues ', Transpose:=True
h2.Cells(u2, "K") = h1.Cells(i, "A")
h2.Cells(u2, "F") = h1.Cells(i, "D")
h2.Cells(u2, "M") = "IVA"
h2.Cells(u2, "C") = h1.Cells(ren + 1, "B") & "-" & h1.Cells(ren, j)
End If
Next
n = n + 1
If n = 38 Then
ren = ren + 41
i = i + 3
n = 0
End If
Next
'
u3 = h2.Range("E" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear: .SortFields.Add Key:=h1.Range("K3:K" & u3)
.SetRange h1.Range("A2:M" & u3): .Header = xlYes: .Apply
End With
'
'consecutivo
'
u3 = h2.Range("E" & Rows.Count).End(xlUp).Row
ant = h2.Cells(3, "K")
conse = 1
For i = 3 To u3
If ant <> h2.Cells(i, "K") Then
conse = conse + 1
End If
h2.Cells(i, "A") = conse
ant = h2.Cells(i, "K")
Next
End Sub
Esta pregunta está dirigida a Dante Amor.
Muchas gracias.
Slds.
1 Respuesta
Te anexo la macro con la actualización. Lo que hace es verificar celda por celda, desde la E hasta la V, si tiene dato lo copia si no tiene dato se salta a la siguiente celda.
Sub Datos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("OC")
Set h2 = Sheets("oferta_de_compra")
'
u = h2.Range("E" & Rows.Count).End(xlUp).Row
If u = 2 Then u = 3
h2.Range("A3:M" & u).ClearContents
'
n = 0: ren = 1
For i = 3 To h1.Range("E" & Rows.Count).End(xlUp).Row
For j = Columns("E").Column To Columns("V").Column
If h1.Cells(i, j) <> "" Then
u2 = h2.Range("E" & Rows.Count).End(xlUp).Row + 1
h1.Cells(i, j).Copy
h2.Cells(u2, "E").PasteSpecial Paste:=xlPasteValues
h2.Cells(u2, "K") = h1.Cells(i, "A")
h2.Cells(u2, "F") = h1.Cells(i, "D")
h2.Cells(u2, "M") = "IVA"
h2.Cells(u2, "C") = h1.Cells(ren + 1, "B") & "-" & h1.Cells(ren, j)
End If
Next
n = n + 1
If n = 38 Then
n = 0: ren = ren + 41
i = i + 3
End If
Next
'
u3 = h2.Range("E" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear: .SortFields.Add Key:=h1.Range("K3:K" & u3)
.SetRange h1.Range("A2:M" & u3): .Header = xlYes: .Apply
End With
'
'consecutivo
u3 = h2.Range("E" & Rows.Count).End(xlUp).Row
ant = h2.Cells(3, "K")
conse = 1
For i = 3 To u3
If ant <> h2.Cells(i, "K") Then conse = conse + 1
h2.Cells(i, "A") = conse
ant = h2.Cells(i, "K")
Next
MsgBox "copiado terminado"
End SubSaludos.Dante Amor
No olvides valorar la respuesta.
