Macro VBA para concatenar y sacar permutaciones de datos en diferentes rangos
Buenas tardes,
Solicito de ayuda para crear una macro y concatenar o sacar las permutaciones de 3 cifras de los números que están en los 3 rangos:
Tengo 3 tablas con datos, cada tabla consta de 10 celdas, vamos a tomar de ejemplo la fila 4, como pueden ver en la fila 4, en el primer rango tengo los números 1 y 5, en el segundo rango los 3 y 6 y en el tercer rango los números 2 y 9. Si hacemos el calculo de esos números sandrian 8 números permutados (2x2x2=8) que son los que están a partir de la columna "AE". ( Así debería ser el resultado de la macro)
En la fila 5 tengo otros números diferentes y de esos números saldrían 12 números de 3 cifras. (3x2x2=12) en la imagen igualmente coloco a partir de la columna "AE" esta como debería quedar el resultado de la macro al ejecutarse
El tema es que tengo esos rangos con 2 mil filas de datos, así que seria genial que al ejecutar la macro, haga todo el calculo hasta la ultima fila de datos que tenga, en mi caso serian cerca de 2 mil..
En la imagen coloco a manera de ejemplo, como debería ser el resultado de la macro a partir de la columna "AE" (osea, así debería ser el resultado de la macro y empezar a pegar los resultados, solo que yo las copie a mano para dar ejemolo de como debería de dar el resultado)
Tengo poco y nada de conocimientos de macros VBA, discúlpenme si abuso de su conocimiento y pedir todo hecho.. :(
2 Respuestas
Prueba con:
Sub prueba()
Dim wksH As Worksheet
Dim iFila As Integer
Dim a As Byte, b As Byte, c As Byte
Dim x As Byte, y As Byte, z As Byte
Dim iCol As Integer
Set wksH = ThisWorkbook.Worksheets("Hoja1")
With wksH
For iFila = 4 To .[A160000].End(xlUp).Row
For a = 1 To 10
If .Cells(iFila, a).Value <> "" Then
x = .Cells(iFila, 1).Value
For b = 11 To 20
If .Cells(iFila, b).Value <> "" Then
y = .Cells(iFila, b).Value
For c = 21 To 30
If .Cells(iFila, c).Value <> "" Then
z = .Cells(iFila, c).Value
.Cells(iFila, Application.WorksheetFunction.Max(31, .Cells(iFila, 16384).End(xlToLeft).Column) + 1).Value = "'" & CStr(x) & CStr(y) & CStr(z)
End If
Next c
End If
Next b
End If
Next a
Next iFila
End With
Set wksH = Nothing
End SubSaludos_
Veo que hay al menos un "bug": hay que cambiar
x = .Cells(iFila, 1).Value
por
x = .Cells(iFila, a).Value
Saludos_
... Y estoy pensando que si son muchas filas convendría desactivar los cálculos y el refresco de pantalla:
Sub prueba()
Dim wksH As Worksheet
Dim iFila As Integer
Dim a As Byte, b As Byte, c As Byte
Dim x As Byte, y As Byte, z As Byte
Dim iCol As Integer
Set wksH = ThisWorkbook.Worksheets("Hoja1")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With wksH
For iFila = 4 To .[A160000].End(xlUp).Row
For a = 1 To 10
If .Cells(iFila, a).Value <> "" Then
x = .Cells(iFila, a).Value
For b = 11 To 20
If .Cells(iFila, b).Value <> "" Then
y = .Cells(iFila, b).Value
For c = 21 To 30
If .Cells(iFila, c).Value <> "" Then
z = .Cells(iFila, c).Value
.Cells(iFila, Application.WorksheetFunction.Max(31, .Cells(iFila, 16384).End(xlToLeft).Column) + 1).Value = "'" & CStr(x) & CStr(y) & CStr(z)
End If
Next c
End If
Next b
End If
Next a
Next iFila
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set wksH = Nothing
End Sub
El enfoque de esta macro es hacer la concatenación en memoria, de esa manera es más corta la macro y más rápida:
Sub concatenar_permutaciones()
Dim a As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
a = Range("A4:AD" & Range("A" & Rows.Count).End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 1000)
For i = 1 To UBound(a, 1)
n = 1
For j = 1 To 10
If a(i, j) = "" Then Exit For
For k = 11 To 20
If a(i, k) = "" Then Exit For
For m = 21 To 30
If a(i, m) = "" Then Exit For
b(i, n) = a(i, j) & a(i, k) & a(i, m)
n = n + 1
Next m
Next k
Next j
Next i
Range("AE4").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub