如何使用显示所有组合代码中的VBA代码使Excel忽略空白单元格？

Question

我有一些代码，它为我提供了Excel中来自7个不同列的所有可能的数据组合。但是，目前我必须定义填充的特定范围，以便不会有部分空白的产品配置输出。我希望7列中的每一列都有50个选定的单元格范围，这样当添加更多产品选项时，宏就可以重新运行，而不必进入并更新VBA代码中所需的范围。现在的代码是，2-52单元格范围内的任何单元格都是空白的，都会输出带有空白选项的已配置产品。是否可以让宏忽略空白单元格，而仅输出基于已填充单元格的配置？

Sub ListAllCombinations()
'Updateby Extendoffice
Dim xDRg1, xDRg2, xDRg3, xDRg4, xDRg5, xDRg6, xDRg7 As Range
Dim xRg  As Range
Dim xStr As String
Dim xFN1, xFN2, xFN3, xFN4, xFN5, xFN6, xFN7 As Integer
Dim xSV1, xSV2, xSV3, xSV4, xSV5, xSV6, xSV7 As String
Set xDRg1 = Range("A2:A3")  'First column data
Set xDRg2 = Range("B2:B3")  'Second column data
Set xDRg3 = Range("C2:C3")  'Third column data
Set xDRg4 = Range("D2:D2")  'Fourth column data
Set xDRg5 = Range("E2:E2")  'Fifth column data
Set xDRg6 = Range("F2:F3")  'Sixth column data
Set xDRg7 = Range("G2:G2")  'Seventh column data
xStr = "-"   'Separator
Set xRg = Range("L2")  'Output cell
For xFN1 = 1 To xDRg1.Count
    xSV1 = xDRg1.Item(xFN1).Text
    For xFN2 = 1 To xDRg2.Count
        xSV2 = xDRg2.Item(xFN2).Text
      For xFN3 = 1 To xDRg3.Count
          xSV3 = xDRg3.Item(xFN3).Text
        For xFN4 = 1 To xDRg4.Count
            xSV4 = xDRg4.Item(xFN4).Text
          For xFN5 = 1 To xDRg5.Count
              xSV5 = xDRg5.Item(xFN5).Text
            For xFN6 = 1 To xDRg6.Count
                xSV6 = xDRg6.Item(xFN6).Text
              For xFN7 = 1 To xDRg7.Count
                  xSV7 = xDRg7.Item(xFN7).Text
                  xRg.Value = xSV1 & xStr & xSV2 & xStr & xSV3 & xStr & xSV4 & xStr & xSV5 & xStr & xSV6 & xStr & xSV7 & xStr
                  Set xRg = xRg.Offset(1, 0)
                   Next
                Next
             Next
          Next
       Next
    Next
Next
End Sub

Answer 1

列表组合

不过要小心，你可能会用完(1048576). of

Option Explicit

Sub ListAllCombinations()
    Const ProcName As String = "ListAllCombinations"
    On Error GoTo ClearError
    
    Const sName As String = "Sheet1"
    Const sfRow As Long = 2
    Const sColsList As String = "A,B,C,D,E,F,G"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "L2"
    Const dSeparator As String = "="
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim wrCount As Long: wrCount = sws.Rows.Count - sfRow + 1
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim cCount As Long: cCount = UBound(sCols) + 1
    Dim Ranges() As Range: ReDim Ranges(1 To cCount)
    Dim CellsCounts() As Long: ReDim CellsCounts(1 To cCount)
    Dim drCount As Long: drCount = 1
    
    Dim rg As Range
    Dim c As Long
    
    For c = 1 To cCount
        On Error Resume Next
        Set Ranges(c) = sws.Cells(sfRow, sCols(c - 1)).Resize(wrCount) _
            .SpecialCells(xlCellTypeConstants)
        On Error GoTo ClearError
        If Ranges(c) Is Nothing Then Exit Sub
        CellsCounts(c) = Ranges(c).Cells.Count
        drCount = drCount * CellsCounts(c)
    Next c
    
    Dim dData() As String: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim r As Long
    Dim dr As Long
    Dim cc As Long
    Dim StringRepeats As Long
    Dim SequenceRepeats As Long
    Dim CurrentString As String
    For c = 1 To cCount
        dr = 1
        StringRepeats = drCount
        For cc = 1 To c
            StringRepeats = StringRepeats / CellsCounts(cc)
        Next cc
        SequenceRepeats = 1
        If c > 1 Then
            For cc = 1 To c - 1
                SequenceRepeats = SequenceRepeats * CellsCounts(cc)
            Next cc
        End If
        For cc = 1 To SequenceRepeats
            For r = 1 To CellsCounts(c)
                CurrentString = CStr(Ranges(c).Cells(r).Value)
                For dr = dr To dr + StringRepeats - 1
                    dData(dr, c) = CurrentString
                Next dr
            Next r
        Next cc
    Next c
    
    ' Write results to first column.
    Dim dsLength As Long: dsLength = Len(dSeparator)
    For dr = 1 To drCount
        CurrentString = vbNullString
        For c = 1 To cCount
            CurrentString = CurrentString & dData(dr, c) & dSeparator
        Next c
        dData(dr, 1) = Left(CurrentString, Len(CurrentString) - dsLength)
    Next dr
    
    ' Write.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfCell.Resize(drCount)
    drg.Value = dData
    ' Clear.
    Dim dcrg As Range: Set dcrg = dfCell _
        .Resize(dws.Rows.Count - dfCell.Row - drCount + 1).Offset(drCount)
    dcrg.Clear
    ' Autofit.
    dfCell.EntireColumn.AutoFit
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "(" & ProcName & ") " & "Run-time error '" _
       & Err.Number & "': " & Err.Description
    Resume ProcExit
End Sub