VBA - dynamisk datatabel

Hej Jan

Du laver da bare to løkker inde i hinanden. Den \"ydre\" løkke flytter en celle ned når den indre løkke har lavet alle kombinationer af celle a1 og kolonne b.

Jeg vil gerne lave den, men det bliver først senere for jeg har lidt travlt!

ASKIMS

>>>askims
Ja, men det kunne være rart, hvis det var muligt at \"gemme\" listerne, så værdierne i listerne kunne genbruges.

Hej Jan

Den skulle være her:

Sub JanVogt()
\'Flemming Dahl, fd@win-consult.com - december 2001
Dim ValueA() As String
Dim ValueB() As String
Dim iCountA As Integer, iCountB As Integer, iCount As Integer
Dim iX As Integer, iZ As Integer
Dim rCell As Range
Dim bolFound As Boolean

    \'Indlæser forskellige fra kolonne A
    iCountA = 0
    For Each rCell In Range(\"A:A\")
        If rCell = \"\" And rCell.Offset(1, 0) = \"\" Then Exit For
        bolFound = False
        For iX = 0 To iCountA - 1
            If ValueA(iX) = rCell Then bolFound = True
        Next iX
        If bolFound = False Then
            ReDim Preserve ValueA(iCountA)
            ValueA(iCountA) = rCell
            iCountA = iCountA + 1
        End If
    Next rCell

    \'Indlæser forskellige fra kolonne B
    iCountB = 0
    For Each rCell In Range(\"B:B\")
        If rCell = \"\" And rCell.Offset(1, 0) = \"\" Then Exit For
        bolFound = False
        For iX = 0 To iCountB - 1
            If ValueB(iX) = rCell Then bolFound = True
        Next iX
        If bolFound = False Then
            ReDim Preserve ValueB(iCountB)
            ValueB(iCountB) = rCell
            iCountB = iCountB + 1
        End If
    Next rCell

    \'Indsætter alle kombinationerne i Ark2
    iCount = 2
    For iX = 0 To iCountA - 1
        For iZ = 0 To iCountB - 1
            Sheets(\"Ark2\").Range(\"A\" & iCount) = ValueA(iX) & ValueB(iZ)
            iCount = iCount + 1
        Next iZ
    Next iX
End Sub

Tak flemming, det ser fint ud.
Som jeg skriver skal værdierne dog indsættes i hver sin kolonne på Ark2.

Jeg kunne forøvrigt godt lige bruge plads til en overskrift på Ark1.

Jeg kan se, at du dimensionerer i 2 tabeller. Jeg bliver lidt nysgerrig: Kan det lade sig gøre at gøre det i én?

Kolonneoverskrift i Ark1:
    For Each rCell In Range(\"A2:A65536\")
    For Each rCell In Range(\"B2:B65536\")

Hver sin kolonne på to måder:
    \'Indsætter alle kombinationerne i Ark2
    iCount = 2
    For iX = 0 To iCountA - 1
            Sheets(\"Ark2\").Range(\"A\" & iCount) = ValueA(iX)
            iCount = iCount + 1
    Next iX
    iCount = 2
    For iZ = 0 To iCountB - 1
        Sheets(\"Ark2\").Range(\"B\" & iCount) = ValueB(iX)
        iCount = iCount + 1
    Next iZ

eller

rCell

    \'Indsætter alle kombinationerne i Ark2
    iCount = 2
    For iX = 0 To iCountA - 1
        For iZ = 0 To iCountB - 1
            Sheets(\"Ark2\").Range(\"A\" & iCount) = ValueA(iX)
            Sheets(\"Ark2\").Range(\"B\" & iCount) = ValueB(iX)
            iCount = iCount + 1
        Next iZ
    Next iX


Jo, det kan godt lade sig gøre i en Matrix / et Array, hvis størrelsen er fordefineret MyMatrix(12, 8), men du kan ikke Redim flere dimensioner i en Matrix

Glem lige det rCell der står og svæver for sig selv efter \"eller\"

Man kan godt redim i flere dimensioner men man kan ikke redim preserve.
Bortset fra det, så er der jo ikke tale mere end to dimensioner her.
Det betyder at hvis jeg skal lave et redim med en matrix vil det blive sådan:
redim(application.worksheetfunction.counta(range(\"A:A\")) , 2)

for eksempel.
Sub t5()
Dim matrix
Antal_I_Kol_A = Application.WorksheetFunction.CountA(Range(\"A:A\"))
Antal_I_Kol_B = Application.WorksheetFunction.CountA(Range(\"B:B\"))
ReDim matrix(Antal_I_Kol_A, 2)
For x = 1 To UBound(matrix)
    matrix(x, 1) = Cells(x, 1)
Next x
For x = 1 To Antal_I_Kol_B
    matrix(x, 2) = Cells(x, 2)
Next x
For x = 1 To UBound(matrix)
        For y = 1 To Antal_I_Kol_A
            Debug.Print matrix(x, 1), matrix(y, 2)
        Next y
Next x
End Sub

sidste løkke skulle være
For x = 1 To UBound(matrix)
        For y = 1 To Antal_I_Kol_B
            Debug.Print matrix(x, 1), matrix(y, 2)
        Next y
Next x

Hvis nu Antal_I_Kol_B er størst !

If Antal_I_Kol_A > Antal_I_Kol_B Then
    Redim matrix(Antal_I_Kol_A)
Else
    Redim matrix(Antal_I_Kol_B)
Endif

En af årsagerne til at min kode er noget længere er, at den tager højde for at den samme værdi ikke blive indlæst 2 gange fra samme kolonne - således de to matrix\'er kun består af forskellige værdi\'er

>>>Flemming
Der er vist en fejl i din kode. Denne linie
Sheets(\"Ark2\").Range(\"B\" & iCount) = ValueB(iX)

skal i stedet hedde:
Sheets(\"Ark2\").Range(\"B\" & iCount) = ValueB(iZ)

Nu var det kun for at vise det med dim at jeg skrev indlægget.
Mit svar vil være følgende:
Option Base 1
Sub t5()
Dim matrix
Antal_I_Kol_A = Application.WorksheetFunction.CountA(Range(\"A:A\"))
Antal_I_Kol_b = Application.WorksheetFunction.CountA(Range(\"B:B\"))
maxantal = Application.WorksheetFunction.Max(Antal_I_Kol_A, Antal_I_Kol_b)
ReDim matrix(maxantal, 2)
For x = 1 To Antal_I_Kol_A
    matrix(x, 1) = Cells(x, 1)
Next x
For x = 2 To Antal_I_Kol_b
    matrix(x, 2) = Cells(x, 2)
Next x
Worksheets(\"Ark2\").Select
Range(\"a1\").Select
For x = 2 To Antal_I_Kol_A
        For y = 2 To Antal_I_Kol_b
            Selection.Offset(1, 0) = matrix(x, 1)
            Selection.Offset(1, 1) = matrix(y, 2)
            Selection.Offset(1, 0).Select
        Next y
Next x
End Sub

Selvfølgelig har du, Flemming. Der skal dimensiones efter største antal.

mellemste løkke bør i princippet ændres til for x = 1 to Antal_I_Kol_B

>>>flemming og bak
Tak for hjælpen. Begge jeres eksempler var meget lærerige.
Personligt foretrækker jeg baks løsning, men flemming var først - derfor pointene.

Løsningerne gør to forskellige ting.

Hvis der findes flere celler i en kolonne med \"flemming\", så kommer den kun med en gang i min løsning, hvor den kommer med alle gange i bak\'s løsning, så det er behov afhængig.

Bak>> brug i så vidt muligt ikke select og selection, idet disse sløver processen. Her skal markøren flyttes en ned inden nye data kan indsættes. Kode med Range fremfor Select afvikles noget hurtigere.

Tak for point, Jan
Flemming>> Tak for tippet, jeg har ikke målt på det, men det ud til at du har ret mht. hastighed.
Jeg har prøvet at ændre sidste del af koden og det virker hurtigere.
Worksheets(\"Ark2\").Select
a = 0
For x = 2 To Antal_I_Kol_A
        For y = 2 To Antal_I_Kol_b
            a = a + 1
            Cells(a, 1) = matrix(x, 1)
            Cells(a, 2) = matrix(y, 2)
        Next y
Next x

*S* cells er lidt hurtigere en range, som igen er en del hurtigere en select / selection.
Ved mange select, er cells/range MEGET hurtigere, ses endnu tydligere på en ændre pc.

Du kunne endda lave det til: Sheets(\"Ark2\").Cells(a, 1) = matrix(x, 1)

og så slette Worksheets(\"Ark2\").Select

Så det bliver bedre og bedre.
With Worksheets(\"Ark2\")
For x = 2 To Antal_I_Kol_A
        For y = 2 To Antal_I_Kol_b
            a = a + 1
            .Cells(a, 1) = matrix(x, 1)
            .Cells(a, 2) = matrix(y, 2)
        Next y
Next x
End With