arrays - tamaño - tablas largas en latex

Expandir celdas de columna para cada celda de columna

Question

Tengo 3 conjuntos diferentes de datos (en diferentes columnas)

1. Animales (5 tipos diferentes) en la columna A
2. Frutas (1000 tipos diferentes) en la columna B
3. Países (10 tipos diferentes) en la columna C

Con estas 3 colecciones de datos, me gustaría recibir 5 × 1000 × 10 para un total de 50k elementos correspondientes en col. EFG (cada animal que corresponde con cada fruta y cada país).

Puede hacerse copiando y pegando valores manualmente, pero llevará años. ¿Hay alguna forma de automatizarlo por código VBA o

¿Existe alguna fórmula universal para conjuntos de datos ilimitados como el presentado anteriormente? Avíseme si algo no está claro.

Aquí hay un ejemplo más pequeño de datos y cómo deberían resultar los resultados:

Answer 1

Aquí hay una versión recursiva. Se supone que los datos no contienen pestañas internas ya que la función principal devuelve cadenas de producto que están delimitadas por tabuladores. El sub principal debe pasar un rango que consiste en los datos junto con la celda de la esquina superior izquierda del rango de salida. Esto probablemente podría modificarse un poco, pero es adecuado para fines de prueba.

ColumnProducts Range("A:C"), Range("E1")

Es la llamada que resuelve el problema de OP. Aquí está el código:

''the following function takes a collection of arrays of strings
''and returns a variant array of tab-delimited strings which
''comprise the (tab-delimited) cartesian products of
''the arrays in the collection
Function CartesianProduct(ByVal Arrays As Collection) As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim head As Variant
Dim tail As Variant
Dim product As Variant
If Arrays.Count = 1 Then
CartesianProduct = Arrays.Item(1)
Exit Function
Else
head = Arrays.Item(1)
Arrays.Remove 1
tail = CartesianProduct(Arrays)
m = UBound(head)
n = UBound(tail)
ReDim product(1 To m * n)
k = 1
For i = 1 To m
For j = 1 To n
product(k) = head(i) & vbTab & tail(j)
k = k + 1
Next j
Next i
CartesianProduct = product
End If
End Function
Sub ColumnProducts(data As Range, output As Range)
Dim Arrays As New Collection
Dim strings As Variant, product As Variant
Dim i As Long, j As Long, n As Long, numRows As Long
Dim col As Range, cell As Range
Dim outRange As Range
numRows = Range("A:A").Rows.Count
For Each col In data.Columns
n = col.EntireColumn.Cells(numRows).End(xlUp).Row
i = col.Cells(1).Row
ReDim strings(1 To n - i + 1)
For j = 1 To n - i + 1
strings(j) = col.Cells(i + j - 1)
Next j
Arrays.Add strings
Next col
product = CartesianProduct(Arrays)
n = UBound(product)
Set outRange = Range(output, output.Offset(n - 1))
outRange.Value = Application.WorksheetFunction.Transpose(product)
outRange.TextToColumns Destination:=output, DataType:=xlDelimited, Tab:=True
End Sub

Answer 2

Aquí, mi enfoque para su problema.

Public Sub matchingCell()
Dim animalRow, fruitRow, countryRow, checkRow, resultRow As Long
Dim isExist As Boolean
''Set the start row
animalRow = 2
resultRow = 2
''Work with data sheet
With Sheets("sheetname")
''Loop until animals column is blank
Do While .Range("A" & animalRow) <> ""
''Set the start row
fruitRow = 2
''Loop until fruits column is blank
Do While .Range("B" & fruitRow) <> ""
''Set the start row
countryRow = 2
''Loop until country column is blank
Do While .Range("C" & countryRow) <> ""
''Set the start row
checkRow = 2
''Reset flag
isExist = False
''Checking for duplicate row
''Loop all result row until D is blank
Do While .Range("D" & checkRow) <> ""
''If duplicate row found
If .Range("D" & checkRow) = .Range("A" & animalRow) And _
.Range("E" & checkRow) = .Range("B" & fruitRow) And _
.Range("F" & checkRow) = .Range("C" & countryRow) Then
''Set true for exist flag
isExist = True
End If
checkRow = checkRow + 1
Loop
''If duplicate row not found
If Not isExist Then
.Range("D" & resultRow) = .Range("A" & animalRow)
.Range("E" & resultRow) = .Range("B" & fruitRow)
.Range("F" & resultRow) = .Range("C" & countryRow)
''Increase resultRow
resultRow = resultRow + 1
End If
''Increase countryRow
countryRow = countryRow + 1
Loop
''Increase fruitRow
fruitRow = fruitRow + 1
Loop
''Increase fruitRow
animalRow = animalRow + 1
Loop
End With
End Sub

Ya lo probé. Funciona bien Que tengas un buen día.

Answer 3

Bien, entonces solo quieres una lista de todas las combinaciones posibles. Esto es lo que haría:

• Primero seleccione los datos sin procesar y elimine los duplicados, columna por columna.
• Luego lea estas 3 columnas en 3 matrices separadas.
• Calcule la longitud total de todas las matrices.
• Luego, con un bucle, pegue el primer valor de la matriz del país tantas veces como haya combinaciones de animales y frutas, por lo que la longitud de esas matrices se multiplicó.
• Dentro del ciclo, haga otro ciclo que publique todas las opciones de frutas. Con un número de filas duplicadas que es igual al número máximo de animales.
• Luego pegue los animales sin duplicados siguiéndose hasta la última fila de la mesa.

Answer 4

Ejemplo clásico de una instrucción SQL de selección sin unión que devuelve el Producto cartesiano de todos los resultados combinados de las tablas enumeradas.

Solución de base de datos SQL

Simplemente importe Animals, Fruit, Country como tablas separadas en cualquier base de datos SQL como MS Access, SQLite, MySQL, etc. y enumere las tablas sin combinaciones, incluidas las combinaciones implícitas ( WHERE ) y explícitas ( JOIN ):

SELECT Animals.Animal, Fruits.Fruit, Countries.Country
FROM Animals, Countries, Fruits;

Solución Excel

El mismo concepto con la ejecución de la instrucción SQL sin unión en VBA usando una conexión ODBC al libro de trabajo que contiene rangos de animales, países y frutas. Por ejemplo, cada grupo de datos está en su propia hoja de trabajo del mismo nombre.

Sub CrossJoinQuery()
Dim conn As Object
Dim rst As Object
Dim sConn As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sConn = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "DBQ=C:/Path To/Excel/Workbook.xlsx;"
conn.Open sConn
strSQL = "SELECT * FROM [Animals$A1:A3], [Fruits$A1:A3], [Countries$A1:A3] "
rst.Open strSQL, conn
Range("A1").CopyFromRecordset rst
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub

Answer 5

En realidad, quiero modificar mi respuesta anterior. Pero, mi nueva respuesta es completamente diferente de la anterior. Porque, la respuesta anterior es para una columna específica y esta es para una columna universal. Después de contestar la respuesta anterior, el interrogador dice un nuevo requisito que quiere hacer en universal. Para una columna fija, podemos pensar en un bucle fijo y para una columna infinita, debemos pensar de otra manera. Entonces, yo también lo hago. Y los usuarios de SO también pueden ver las diferencias de código y creo que esto será útil para los principiantes.

Este nuevo código no es tan simple como el anterior. Si desea saber claramente sobre el código, sugerí depurar el código en línea por línea.

No te preocupes por el código. Ya lo probé paso a paso. A mí me funciona perfectamente. Si no es para ti, avísame. Una cosa es que este código puede causar un error para la fila en blanco (que no tiene datos). Porque, actualmente, no agregué verificar eso.

Aquí está mi enfoque universal para su problema:

Public Sub matchingCell()
Dim startRawColumn, endRawColumn, startResultColumn, endResultColumn, startRow As Integer
Dim index, row, column, containerIndex, tempIndex As Integer
Dim columnCount, totalCount, timesCount, matchingCount, tempCount As Integer
Dim isExist As Boolean
Dim arrayContainer() As Variant
''Actually, even it is for universal, we need to know start column and end column of raw data.
''And also start row. And start column for write result.
''I set them for my test data.
''You need to modify them(startRawColumn, endRawColumn, startRow, startResultColumn).
''Set the start column and end column for raw data
startRawColumn = 1
endRawColumn = 3
''Set the start row for read data and write data
startRow = 2
''Set the start column for result data
startResultColumn = 4
''Get no of raw data column
columnCount = endRawColumn - startRawColumn
''Set container index
containerIndex = 0
''Re-create array container for count of column
ReDim arrayContainer(0 To columnCount)
With Sheets("sheetname")
''Getting data from sheet
''Loop all column for getting data of each column
For column = startRawColumn To endRawColumn Step 1
''Create tempArray for column
Dim tempArray() As Variant
''Reset startRow
row = startRow
''Reset index
index = 0
''Here is one things. I looped until to blank.
''If you want anymore, you can modify the looping type.
''Don''t do any changes to main body of looping.
''Loop until the cell is blank
Do While .Cells(row, column) <> ""
''Reset isExist flag
isExist = False
''Remove checking for no data
If index > 0 Then
''Loop previous data for duplicate checking
For tempIndex = 0 To index - 1 Step 1
''If found, set true to isExist and stop loop
If tempArray(tempIndex) = .Cells(row, column) Then
isExist = True
Exit For
End If
Next tempIndex
End If
''If there is no duplicate data, store data
If Not isExist Then
''Reset tempArray
ReDim Preserve tempArray(index)
tempArray(index) = .Cells(row, column)
''Increase index
index = index + 1
End If
''Increase row
row = row + 1
Loop
''Store column with data
arrayContainer(containerIndex) = tempArray
''Increase container index
containerIndex = containerIndex + 1
Next column
''Now, we got all data column including data which has no duplicate
''Show result data on sheet
''Getting the result row count
totalCount = 1
''Get result row count
For tempIndex = 0 To UBound(arrayContainer) Step 1
totalCount = totalCount * (UBound(arrayContainer(tempIndex)) + 1)
Next tempIndex
''Reset timesCount
timesCount = 1
''Get the last column for result
endResultColumn = startResultColumn + columnCount
''Loop array container
For containerIndex = UBound(arrayContainer) To 0 Step -1
''Getting the counts for looping
If containerIndex = UBound(arrayContainer) Then
duplicateCount = 1
timesCount = totalCount / (UBound(arrayContainer(containerIndex)) + 1)
Else
duplicateCount = duplicateCount * (UBound(arrayContainer(containerIndex + 1)) + 1)
timesCount = timesCount / (UBound(arrayContainer(containerIndex)) + 1)
End If
''Reset the start row
row = startRow
''Loop timesCount
For countIndex = 1 To timesCount Step 1
''Loop data array
For index = 0 To UBound(arrayContainer(containerIndex)) Step 1
''Loop duplicateCount
For tempIndex = 1 To duplicateCount Step 1
''Write data to cell
.Cells(row, endResultColumn) = arrayContainer(containerIndex)(index)
''Increase row
row = row + 1
Next tempIndex
Next index
Next countIndex
''Increase result column index
endResultColumn = endResultColumn - 1
Next containerIndex
End With
End Sub

Answer 6

Entiendo por universal , quieres que esto acomode cualquier número de columnas y cualquier número de entradas en cada una. Algunas matrices variantes deberían proporcionar las dimensiones necesarias para calcular los ciclos de repetición para cada valor.

Option Explicit
Sub main()
Call for_each_in_others(rDATA:=Worksheets("Sheet3").Range("A3"), bHDR:=True)
End Sub
Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
Dim v As Long, w As Long
Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant
On Error GoTo bm_Safe_Exit
appTGGL bTGGL:=False
With rDATA.Parent
With rDATA(1).CurrentRegion
''Debug.Print rDATA(1).Row - .Cells(1).Row
With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
sErrorRng = .Address(0, 0)
vTMPs = .Value2
ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
iMAXROWS = 1
''On Error GoTo bm_Output_Exceeded
For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
vCOLs(w) = Application.CountA(.Columns(w))
iMAXROWS = iMAXROWS * vCOLs(w)
Next w
''control excessive or no rows of output
If iMAXROWS > Rows.Count Then
GoTo bm_Output_Exceeded
ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
GoTo bm_Nothing_To_Do
End If
On Error GoTo bm_Safe_Exit
ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
iINCROWS = 1
For w = LBound(vVALs, 2) To UBound(vVALs, 2)
iINCROWS = iINCROWS * vCOLs(w)
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
Next v
Next w
End With
End With
.Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
If bHDR Then
rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
End If
rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
GoTo bm_Safe_Exit
bm_Nothing_To_Do:
MsgBox "There is not enough data in " & sErrorRng & " to perform expansion." & Chr(10) & _
"This could be due to a single column of values or one or more blank column(s) of values." & _
Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
"Single or No Column of Raw Data"
GoTo bm_Safe_Exit
bm_Output_Exceeded:
MsgBox "The number of expanded values created from " & sErrorRng & _
" (" & Format(iMAXROWS, "/> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
" columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
"Too Many Entries"
bm_Safe_Exit:
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.EnableEvents = bTGGL
Application.ScreenUpdating = bTGGL
End Sub

Coloque las etiquetas de encabezado de columna en la fila 2 comenzando en la columna A y los datos directamente debajo de eso.

He agregado algunos controles de error para advertir de exceder el número de filas en una hoja de trabajo. Esto normalmente no es algo que probablemente sea una consideración, pero multiplicar el número de valores en un número indeterminado de columnas entre sí puede producir rápidamente una gran cantidad de resultados. No es imprevisible que supere las 1.048.576 filas.

Answer 7

Mi primer acercamiento a este problema fue similar al publicado por @Jeeped:

1. cargar columnas de entrada al conjunto y contar filas en cada columna
2. llenar matriz con todas las combinaciones
3. asignar matriz al rango de salida

Usando MicroTimer he calculado los tiempos promedio tomados por cada parte del algoritmo anterior. La parte 3. tomó 90% -93% del tiempo total de ejecución para datos de entrada más grandes.

A continuación se muestra mi intento de mejorar la velocidad de escritura de datos en la hoja de trabajo. He definido una constante iMinRSize=17 . Una vez que es posible llenar más de iMinRSize filas consecutivas con el mismo valor, el código deja de archivar la matriz y escribe directamente en el rango de la hoja de trabajo.

Sub CrossJoin(rSrc As Range, rTrg As Range)
Dim vSrc() As Variant, vTrgPart() As Variant
Dim iLengths() As Long
Dim iCCnt As Integer, iRTrgCnt As Long, iRSrcCnt As Long
Dim i As Integer, j As Long, k As Long, l As Long
Dim iStep As Long
Const iMinRSize As Long = 17
Dim iArrLastC As Integer
On Error GoTo CleanUp
Application.ScreenUpdating = False
Application.EnableEvents = False
vSrc = rSrc.Value2
iCCnt = UBound(vSrc, 2)
iRSrcCnt = UBound(vSrc, 1)
iRTrgCnt = 1
iArrLastC = 1
ReDim iLengths(1 To iCCnt)
For i = 1 To iCCnt
j = iRSrcCnt
While (j > 0) And IsEmpty(vSrc(j, i))
j = j - 1
Wend
iLengths(i) = j
iRTrgCnt = iRTrgCnt * iLengths(i)
If (iRTrgCnt < iMinRSize) And (iArrLastC < iCCnt) Then iArrLastC = iArrLastC + 1
Next i
If (iRTrgCnt > 0) And (rTrg.row + iRTrgCnt - 1 <= rTrg.Parent.Rows.Count) Then
ReDim vTrgPart(1 To iRTrgCnt, 1 To iArrLastC)
iStep = 1
For i = 1 To iArrLastC
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
For l = j To j + iStep - 1
vTrgPart(l, i) = vSrc(k, i)
Next l
Next j
iStep = iStep * iLengths(i)
Next i
rTrg.Resize(iRTrgCnt, iArrLastC) = vTrgPart
For i = iArrLastC + 1 To iCCnt
k = 0
For j = 1 To iRTrgCnt Step iStep
k = k + 1
If k > iLengths(i) Then k = 1
rTrg.Resize(iStep).Offset(j - 1, i - 1).Value2 = vSrc(k, i)
Next j
iStep = iStep * iLengths(i)
Next i
End If
CleanUp:
Application.ScreenUpdating = True
Application.EnableEvents = False
End Sub
Sub test()
CrossJoin Range("a2:f10"), Range("k2")
End Sub

Si establecemos iMinRSize en Rows.Count , todos los datos se escriben en la matriz. A continuación se muestran mis resultados de prueba de muestra:

El código funciona mejor si las columnas de entrada con el mayor número de filas son lo primero, pero no sería un gran problema modificar el código para clasificar las columnas y procesarlas en el orden correcto.

Answer 8

Puede hacer esto con fórmulas de hoja de trabajo. Si tiene rangos NAME''d: animales, frutas y países, el "truco" es generar índices en esa matriz para proporcionar todas las combinaciones.

Por ejemplo:

=CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)

generará una serie de números basada en 1 que se repite para las entradas de números en Fruits * Countries, lo que le da cuántas filas necesita para cada animal.

=MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1

generará una serie basada en 1 que repite cada fruta para el número de países.

=MOD(ROWS($1:1)-1,ROWS(Countries))+1))

Genera una secuencia repetitiva de 1..n donde n es el número de países.

Poniendo esto en fórmulas (con alguna comprobación de errores)

D3: =IFERROR(INDEX(Animals,CEILING(ROWS($1:1)/(ROWS(Fruits)*ROWS(Countries)),1)),"")
E3: =IF(E3="","",INDEX(Fruits,MOD(CEILING(ROWS($1:1)/ROWS(Countries),1)-1,ROWS(Fruits))+1))
F3: =IF(E3="","",INDEX(Countries,MOD(ROWS($1:1)-1,ROWS(Countries))+1))