Расширение ячеек столбцов для каждой ячейки столбца

Ответ 1

Мой первый подход к этой проблеме был похож на тот, который был отправлен @Jeeped:

• загружать входные столбцы в массив и подсчитывать строки в каждом столбце
• заполнить массив всеми комбинациями
• присваивать массив выходному диапазону

Использование MicroTimer Я вычислил среднее время, затраченное каждой частью алгоритма. Часть 3. занимала 90% -93% от общего времени выполнения для больших входных данных.

Ниже приведена моя попытка улучшить скорость записи данных на рабочий лист. Я определил константу iMinRSize=17. После того, как возможно заполнить более чем iMinRSize последовательные строки с одним и тем же значением, код перестает заполнять массив и записывать непосредственно в диапазон рабочих листов.

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

Если мы установим iMinRSize в Rows.Count, все данные записываются в массив. Ниже приведены мои тестовые результаты:

Код лучше всего работает, если сначала введите начальные столбцы с наибольшим количеством строк, но это не будет большой проблемой для изменения кода для ранжирования столбцов и обработки в правильном порядке.

Ответ 2

Я собираюсь по универсальному, вы хотите, чтобы это вмещало любое количество столбцов и любое количество записей в каждом. Несколько вариантов массивов должны содержать размеры, необходимые для расчета циклов повторения для каждого значения.

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

Поместите метки заголовков столбцов в строку 2, начиная с столбца A, и данные непосредственно ниже.

Я добавил некоторое управление ошибкой, чтобы предупредить о превышении количества строк на листе. Обычно это не то, что может быть рассмотрено, но умножение количества значений в неопределенном количестве столбцов друг на друга может быстро привести к большому количеству результатов. Не предвидится, что вы превысите 1 048 576 строк.

Ответ 3

Классический пример команды выбора без соединения, которая возвращает декартово произведение всех результатов комбинирования перечисленных таблиц.

SQL Database Solution

Просто импортируйте Animals, Fruit, Country в виде отдельных таблиц в любую базу данных SQL, такую ​​как MS Access, SQLite, MySQL и т.д., и таблицы таблиц без объединений, включая неявные (WHERE) и явные (JOIN) соединения:

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

Решение Excel

Такая же концепция с запуском инструкции non-join SQL в VBA с использованием ODBC-соединения с книгой, содержащей диапазоны "Животные, страны и фрукты". Например, каждая группировка данных находится в собственном листе с тем же именем.

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

Ответ 4

Вы можете сделать это с помощью формул рабочего листа. Если у вас есть диапазоны NAME - Животные, Фрукты и Страны, "трюк" состоит в том, чтобы генерировать индексы в этот массив, чтобы предоставить все различные комбинации.

Например:

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

будет генерировать последовательность чисел на основе 1, которая повторяется для записей чисел в Fruits * Countries, что дает вам, сколько строк вам нужно для каждого животного.

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

будет генерировать последовательность на основе 1, которая повторяет каждый Fruit для числа стран.

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

Создает повторяющуюся последовательность 1..n, где n - количество стран.

Вводя их в формулы (с некоторой проверкой ошибок)

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))

Ответ 5

Собственно, я хочу изменить свой старый ответ. Но мой новый ответ полностью отличается от старого ответа. Потому что, старый ответ для конкретной колонки, и этот для универсального столбца. Отвечая на старый ответ, вопроситель говорит новое требование, которое он хочет сделать в универсальном. Для фиксированного столбца мы можем думать о фиксированном цикле и для бесконечного столбца, нам нужно думать по-другому. Итак, я тоже это делаю. И пользователи SO также могут видеть различия в коде, и я думаю, это будет полезно для новичков.

Этот новый код не так прост, как старый. Если вы хотите четко знать код, я предложил для отладки кода в строке за строкой.

Не беспокойтесь о коде. Я уже тестировал это шаг за шагом. Это отлично работает для меня. Если это не для вас, пожалуйста, дайте мне знать. Одна вещь заключается в том, что этот код может вызвать ошибку для пустой строки (у которой нет данных). Потому что в настоящее время я не добавил для этого проверку.

Вот мой универсальный подход к вашей проблеме:

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

Ответ 6

Хорошо, так что вам просто нужен список всех возможных комбинаций. Вот что я буду делать:

• Сначала выберите необработанные данные и удалите дубликаты, по столбцу.
• Затем прочитайте эти 3 столбца на 3 отдельных массивах.
• Рассчитать общую длину всех массивов.
• Затем с петлей вставьте первое значение массива страны столько раз, сколько есть комбинаций животных и плодов, поэтому длина этих массивов будет умножена.
• Внутри цикла создайте еще один цикл, который помещает все варианты фруктов. С несколькими повторяющимися строками, которые равны максимальному количеству животных.
• Затем вставьте животных без дубликатов, следующих друг за другом, до последней строки таблицы.

Ответ 7

Вот мой подход к вашей проблеме.

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

Я уже тестировал его. Он работает хорошо. Приятного дня.

Ответ 8

Вот рекурсивная версия. Он предполагает, что данные не содержат никаких внутренних вкладок, поскольку основная функция возвращает строки продуктов, которые разделены табуляцией. Основному подпункту необходимо передать диапазон, состоящий из данных вместе с верхней левой угловой ячейкой выходного диапазона. Вероятно, это может быть немного изменено, но подходит для целей тестирования.

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

Является ли вызов, который решает проблему OP. Вот код:

'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