Extender la cantidad de números copiados en 1 fila
Tengo que utilizar esta Macro pero en el momento de su confección solamente necesitaba copiar 20 números y ahora necesito extender la cantidad a
24 numeros, envio el codigo y la planilla para su evaluacion.
1 Respuesta
Respuesta de Dante Amor
1
Sub Copiar_Numeros()
Dim iniTime!, fRow&, lRow&, k&
iniTime = Timer
Application.ScreenUpdating = False
fRow = 1
lRow = Cells(Rows.Count, "u").End(xlUp).Row
For k = fRow To lRow Step 10000
Auxiliar Range("a" & k, "u" & Application.Min(k + 10000 - 1, lRow))
DoEvents
Next
MsgBox "Proceso terminado en " & Format(Timer - iniTime, "0.00 seg")
Application.ScreenUpdating = True
End Sub
Private Sub Auxiliar(Rng As Range)
Dim Q&, i&, j%, R%
Dim Mat1, Mat2
Mat1 = Rng
Q = UBound(Mat1): R = UBound(Mat1, 2)
ReDim Mat2(1 To Q, 1 To 10 + R)
R = 0
For i = 1 To Q
If Mat1(i, 21) > 2 And Mat1(i, 21) < 8 Then
R = 0
For j = 1 To 20
If Mat1(i, j) <> "" Then
R = 1 + R
Mat2(i, R) = Mat1(i, j)
End If
Next
End If
Next
Cells(Rng.Row, "v").Resize(Q, UBound(Mat2, 2)) = Mat2
Mat1 = Empty: Mat2 = Empty
End Sub
Ahi te envie el codigo como lo indicaste podras enviarme la modificacion para poder copiar los 24 numeros en lugar de 20.
Gracias
Te paso el código actualizado:
Si quieres aumentar o disminuir columnas, cambia la letra "Y" en esta línea:
a = Range("A2", Range("Y" & Rows.Count).End(3)).Value2por la letra de la nueva columna.
Prueba con la siguiente macro.
Sub Copiar_Numeros_2()
Dim iniTime!
Dim i As Long, j As Long, k As Long, ub As Long
Dim a As Variant, b As Variant
'
a = Range("A2", Range("Y" & Rows.Count).End(3)).Value2
ub = UBound(a, 2)
ReDim b(1 To UBound(a, 1), 1 To ub)
iniTime = Timer
For i = 1 To UBound(a, 1)
If a(i, ub) > 2 And a(i, ub) < 8 Then
k = 1
For j = 1 To ub - 1
If a(i, j) <> "" Then
b(i, k) = a(i, j)
k = k + 1
End If
Next
End If
Next
Cells(2, ub + 1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
MsgBox "Proceso terminado en " & Format(Timer - iniTime, "0.00 seg")
End Sub
