2

隣接する列の特定のリストから一意の組み合わせを作成するマクロ (または関数) を探すために、Web サイト全体を精査しました。

基本的に、私は持っています：

A  1  F1  R1  
B  2  F2  
C     F3  
D  
E

そして、すべての情報を（同じワークシートと異なる列に）次のようにリストしようとしています：

A 1 F1 R1  
A 1 F2 R1  
A 1 F3 R1  
A 2 F1 R1  
A 2 F2 R1  
A 2 F3 R1  
B 1 F1 R1  
B 1 F2 R1  
B 1 F3 R1  
B 2 F1 R1  
B 2 F2 R1  
B 2 F3 R1  
...etc.

(リストがシートのどこに印刷されるかを切り替えることができるという追加のボーナス)

4

3 に答える 3

2

https://app.box.com/s/47b28f19d794b25511beにワークブックがあり、数式ベースと VBA ベースの両方の方法でそれを行うことができます。

于 2015-10-28T14:26:13.057 に答える
1

次のようにすべての可能な組み合わせを取得するコード

Option Explicit

Sub Combinations()

    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")
    Dim a As Range, b As Range, c As Range, d As Range
    Dim x&, y&, z&, w&

    For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
        Set a = ws.Range("A" & x)
        For y = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row
            Set b = ws.Range("B" & y)
            For z = 1 To ws.Range("C" & Rows.Count).End(xlUp).Row
                Set c = Range("C" & z)
                For w = 1 To ws.Range("D" & Rows.Count).End(xlUp).Row
                    Set d = ws.Range("D" & w)
                    Debug.Print a & vbTab & b & vbTab & c & vbTab & d
                    Set d = Nothing
                Next
                Set c = Nothing
            Next
            Set b = Nothing
        Next y
        Set a = Nothing
    Next x

End Sub

そして出力

A   1   F1  R1
A   1   F2  R1
A   1   F3  R1
A   2   F1  R1
A   2   F2  R1
A   2   F3  R1
B   1   F1  R1
B   1   F2  R1
B   1   F3  R1
B   2   F1  R1
B   2   F2  R1
B   2   F3  R1
C   1   F1  R1
C   1   F2  R1
C   1   F3  R1
C   2   F1  R1
C   2   F2  R1
C   2   F3  R1
D   1   F1  R1
D   1   F2  R1
D   1   F3  R1
D   2   F1  R1
D   2   F2  R1
D   2   F3  R1
E   1   F1  R1
E   1   F2  R1
E   1   F3  R1
E   2   F1  R1
E   2   F2  R1
E   2   F3  R1
于 2013-05-29T18:23:21.777 に答える
0

この VBA コードを試してください:

Type tArray
    value As String
    count As Long
End Type

Sub combineAll()
    Dim sResult(10) As tArray, rRow(10) As Long, str() As String
    Dim sRow As Long, sCol As Long
    Dim i As Long, r As Long
    Dim resRows As Long
    sRow = 1: sCol = 1: r = 0

    With ActiveSheet
        Do
            rRow(sCol) = 1
            If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
            Do
                If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
                sResult(sCol).value = sResult(sCol).value & Trim(.Cells(sRow, sCol).value) & ";"
                sResult(sCol).count = sResult(sCol).count + 1
                sRow = sRow + 1
            Loop
            sCol = sCol + 1
            sRow = 1
        Loop

        Do
            r = r + 1
            For i = 1 To sCol - 1
                str = Split(sResult(i).value, ";")
                .Cells(r, sCol + i).value = str(rRow(i) - 1)
            Next i

            For i = sCol - 1 To 1 Step -1
                If rRow(i) < sResult(i).count Then
                    rRow(i) = rRow(i) + 1
                    Exit For
                Else
                    rRow(i) = 1
                End If
            Next i

            If rRow(1) >= sResult(1).count Then Exit Do
        Loop

    End With

End Sub
于 2015-04-28T23:48:53.020 に答える