Waarde variabel maken in VBA

[Toondeboon]

Hallo iedereen,

Ik heb een probleempje in VBA. De volgende macro maakt van een set waarden alle mogelijk combinaties. (dus het aantal waarden tot de macht 2)

In onderstaande code staat op de tweede regel de waarde 11 achter h.

Nu wil ik die eigenlijk variabel hebben en dus doorlinken naar een cel in de sheet, zodat ik op de plaats van dat getal 11 altijd het getal kan weergeven dat precies het aantal variabelen is dat gebruikt wordt om combinaties te maken. Nu staan er bijvoorbeeld 11 waarden in sheet 2, maar dit kunnen er soms ook maar 4 worden. Dan moet dat getal 11 dus veranderen in 4.

Wie o wie kan me helpen dat getal 11 variabel te maken?

Ik kreeg alleen een .xlsx bestand geüpload, klopt het dat er geen .xlsm mogelijk is??

Bij voorbaat dank!

PS misschien heeft nog iemand een oplossing om die regels h(0) = Worksheets("Sheet2").Range("A1") , enz, ook in te korten, dat ik niet 100 van die regels moet gaan invoeren als er een keer 100 waardes gebruikt moeten worden om combinaties te maken.

Sub CreateString3()
Dim h(11) As Variant
Dim buildString As String
Dim rangeString As String
Dim myRange As Range
Dim rangeNR As Integer
rangeNR = 1
h(0) = Worksheets("Sheet2").Range("A1")
h(1) = Worksheets("Sheet2").Range("A2")
h(2) = Worksheets("Sheet2").Range("A3")
h(3) = Worksheets("Sheet2").Range("A4")
h(4) = Worksheets("Sheet2").Range("A5")
h(5) = Worksheets("Sheet2").Range("A6")
h(6) = Worksheets("Sheet2").Range("A7")
h(7) = Worksheets("Sheet2").Range("A8")
h(8) = Worksheets("Sheet2").Range("A9")
h(9) = Worksheets("Sheet2").Range("A10")
h(10) = Worksheets("Sheet2").Range("A11")
h(11) = Worksheets("Sheet2").Range("A12")
For g = 0 To 10
For i = 0 To 10
rangeNR = rangeNR + 1
rangeString = "A" & rangeNR
buildString = h(g) & "-" & h(i)
Set myRange = Worksheets("Sheet1").Range(rangeString).Cells
myRange.Value = buildString
Next i
Next g
End Sub

 

[paulva]

Je kan dat door:

    Dim h() As String
    ReDim h(sheets(1).cells(1,1))
    h(2) = "test"

Macro's kan je uploaden door het oude xls formaat te gebruiken.

 

[Toondeboon]

Hallo Paulva,

Die werkt alvast!! Bedankt! Maar nu loop ik tegen het volgende probleem aan: als ik dan bijvoorbeeld die variabele waarde op 3 heb staan, dan staan onderstaande regels er nog steeds, en geeft Excel dus aan dat ie daar niks mee kan, omdat er dus meer dan 4 regels staan. (dus ook h(4) / h(5) / h(6) / enz.

h(0) = Worksheets("Sheet2").Range("A1")
h(1) = Worksheets("Sheet2").Range("A2")
h(2) = Worksheets("Sheet2").Range("A3")
h(3) = Worksheets("Sheet2").Range("A4")
h(4) = Worksheets("Sheet2").Range("A5")
h(5) = Worksheets("Sheet2").Range("A6")
h(6) = Worksheets("Sheet2").Range("A7")
h(7) = Worksheets("Sheet2").Range("A8")
h(8) = Worksheets("Sheet2").Range("A9")
h(9) = Worksheets("Sheet2").Range("A10")

Met datzelfde probleem zit ik ook bij het gedeelte
For g = 0 To 9
For i = 0 To 9
omdat die 9 dus mee zou moeten veranderen met de variabele waarde zoals bovenaan nu wel gedaan is.

Wie kan me verder helpen?
Bij voorbaat kei bedankt!

 

[paulva]

Wel, het zou op deze manier kunnen:

	Dim h() As String
	intMaximum = sheets("Sheet1").cells(1,1).value
    	ReDim h(intMaximum)
    	for intTeller = 0 to intMaximum
   		h(intTeller)= sheets("Sheet2").cells(intTeller+1,1).value
	next

 

[Mark xl]

Sorry dat ik altijd complete oplossingen neerplemp, maar volgens mij is dit wat je zoekt
Stel de waarde van constante nAantalrijen in naar behoefte.

Deze macro is ook vele malen sneller omdat ik maar één keer een werkblad lees en één keer schrijf.

Mark.

Sub CreateStrings()
Const nAantalrijen As Long = 11 'het aantal rijen

Dim vSource As Variant
Dim vSet As Variant

Dim i As Long
Dim g As Long

vSource = Sheets("Sheet2").Range("A1:A" & nAantalrijen)
ReDim vSet(nAantalrijen ^ 2)

For i = 0 To UBound(vSource, 1) - 1
    For g = 0 To UBound(vSource, 1) - 1
        vSet((i * nAantalrijen) + g) = vSource(i + 1, 1) + "-" + vSource(g + 1, 1)
    Next g
Next i

Sheets("Sheet1").Range("A1").Resize(nAantalrijen ^ 2) = WorksheetFunction.Transpose(vSet)

End Sub

Nog een klein stukje uitleg:
een normale Array waarvan je de dimensies vaststelt met REDIM begint bij 0 (tenzij je de instructie "option base 1" gebruikt)
Een werkblad array die je inleest vanaf een Range object begint altijd met 1.
Handig op te onthouden voor later

 

[Toondeboon]

Beide heren dank ik voor de oplossingen!!

De laatste oplossingen gaat idd erg snel!

Nu heb ik nog twee vragen: hoe krijg ik die waarde 11 (in de laatste oplossing) ook variabel, zoals in de oplossing van Paul? Heb de twee oplossingen proberen te 'combineren' maar dat werkt niet. (bij mij dan )

En aangezien de laatste oplossing zo snel is, hoe zou die indien er bijvoorbeeld 3 verschillende plaatsen komen (dus niet tot de macht 2 maar tot de macht 3) de oplossingen over meerdere tabbladen kunnen wegschrijven? Het houdt bij 55.000 (zoiets?) regels op per tabblad, als je meer combinaties dan dat getal hebt zou ie eigenlijk op een nieuw tabblad verder moeten gaan...

Tsja ik weet het: lastige vragen zo kort voor het weekend!

Maar nogmaals erg bedankt voor de oplossingen so far!!!

 

[Mark xl]

Zo is ie dynamisch

Sub CreateStrings()
Dim nAantalrijen As Long
Dim vAnswer As Variant

Dim vSource As Variant
Dim vSet As Variant

Dim i As Long
Dim g As Long

vAnswer = InputBox("hoeveel rijen??", "Aantal combinaties", 1)

If IsNumeric(vAnswer) Then
    
    nAantalrijen = CLng(vAnswer)
    
    vSource = Sheets("Sheet2").Range("A1:A" & nAantalrijen)
    ReDim vSet(nAantalrijen ^ 2)
    
    For i = 0 To UBound(vSource, 1) - 1
        For g = 0 To UBound(vSource, 1) - 1
            vSet((i * nAantalrijen) + g) = vSource(i + 1, 1) + "-" + vSource(g + 1, 1)
        Next g
    Next i
    
    Sheets("Sheet1").Range("A1").Resize(nAantalrijen ^ 2) = WorksheetFunction.Transpose(vSet)

Else

    MsgBox "Geef een NUMMER op...", vbExclamation, "Wel opletten!"

End If

 

[Mark xl]

En hier een oplossing voor macht3

Sub CreateStringsPower3()
Const nFact As Long = 3 'blijft 3

Dim nAantalrijen As Long
Dim vAnswer As Variant

Dim vSource As Variant
Dim vSet As Variant

Dim i As Long
Dim g As Long
Dim h As Long

vAnswer = InputBox("hoeveel rijen??", "Aantal combinaties", 1)

If IsNumeric(vAnswer) Then
    
    nAantalrijen = CLng(vAnswer)
    
    vSource = Sheets("Sheet2").Range("A1:A" & nAantalrijen)
    ReDim vSet(nAantalrijen ^ nFact)
    
    For i = 0 To UBound(vSource, 1) - 1
        For h = 0 To UBound(vSource, 1) - 1
            For g = 0 To UBound(vSource, 1) - 1
                vSet((i * nAantalrijen) + (h * nAantalrijen) + g) = _
                            vSource(i + 1, 1) + "-" + _
                            vSource(h + 1, 1) + "-" + _
                            vSource(g + 1, 1)
            Next g
        Next h
    Next i
    
    Sheets("Sheet1").Range("A1").Resize(nAantalrijen ^ nFact) = WorksheetFunction.Transpose(vSet)

Else

    MsgBox "Geef een NUMMER op...", vbExclamation, "Wel opletten!"

End If

End Sub

 

[Toondeboon]

Het wordt steeds gekker! Maar wel mooi hoor!

Alleen klopt het aantal combinaties niet helemaal volgens mij.... ik krijg als ik aantal rijen 3 ingeef maar 15 verschillende combinaties. Dat zou er volgens mij 27 moeten zijn (3 tot de macht 3)

En zodra ik een getal hoger dan 40 ingeef dan geeft ie ook een foutmelding aan.

Waar zou dat aan kunnen liggen?

Alvast enorm bedankt weer!!

 

[Mark xl]

Daar heb je gelijk in.
Ik heb je complete verzoek nu gehonoreerd voor de Macht3 functie
de code is wel wat complexer geworden, mede door een workaround omdat de excel transpose functie een bepaald limiet heeft betreft de matrixgrootte

De foutmelding kreeg je waarschijnlijk omdat 41^3 groter is dan 65535(het maximum aantal rijen op een werkblad)

Hier de nieuwe code:

Sub CreateStringsPower3()
Const nFact As Long = 3 'blijft 3

Dim nAantalrijen As Long
Dim nIndex As Long
Dim vAnswer As Variant

Dim vSource As Variant
Dim vSet As Variant

Dim i As Long
Dim g As Long
Dim h As Long

vAnswer = InputBox("hoeveel rijen??", "Aantal combinaties", 1)

If IsNumeric(vAnswer) Then
    
    nAantalrijen = CLng(vAnswer)
    
    vSource = Sheets("Sheet2").Range("A1:A" & nAantalrijen)
    ReDim vSet(nAantalrijen ^ nFact)
    
    For i = 0 To UBound(vSource, 1) - 1
        For h = 0 To UBound(vSource, 1) - 1
            For g = 0 To UBound(vSource, 1) - 1
                vSet(nIndex) = vSource(i + 1, 1) + "-" + _
                               vSource(h + 1, 1) + "-" + _
                               vSource(g + 1, 1)
                nIndex = nIndex + 1
            Next g
        Next h
    Next i
    
    If (nAantalrijen ^ nFact) <= MaxSheetrows Then
    
        Sheets("Sheet1").Range("A1").Resize(nAantalrijen ^ nFact) = TransposeSingledimension(vSet)

    Else
        
        SpreadResulToMultiplesheets TransposeSingledimension(vSet)
    
    End If
    

Else

    MsgBox "Geef een NUMMER op...", vbExclamation, "Wel opletten!"

End If

End Sub

Private Sub SpreadResulToMultiplesheets(ByVal MyMatrix As Variant)
Dim nMatrixSize As Long
Dim i As Long
Dim nProcessed As Long
Dim pastesheet As Worksheet
nMatrixSize = UBound(MyMatrix)
Set pastesheet = Sheets("Sheet1")
For i = 0 To Int(nMatrixSize / MaxSheetrows)
    If nMatrixSize > (MaxSheetrows + nProcessed) Then
        pastesheet.Range("A1").Resize(MaxSheetrows) = GetPatrialMatrix(MyMatrix, nProcessed, nProcessed + MaxSheetrows - 1)
        nProcessed = nProcessed + MaxSheetrows
        Set pastesheet = Sheets.Add
    Else
        pastesheet.Range("A1").Resize(nMatrixSize - nProcessed) = GetPatrialMatrix(MyMatrix, nProcessed, nMatrixSize)
        Set pastesheet = Nothing
    End If
Next
End Sub

Private Function GetPatrialMatrix(ByVal MyMatrix As Variant, _
                                  ByVal nStart As Long, _
                                  ByVal nEnd As Long) As Variant
Dim i As Long
Dim vResult As Variant
ReDim vResult(nEnd - nStart)
For i = 0 To (nEnd - nStart)
    vResult(i) = MyMatrix(nStart + i, 0)
Next
GetPatrialMatrix = TransposeSingledimension(vResult)
End Function

Private Function MaxSheetrows() As Long
    MaxSheetrows = Cells.SpecialCells(xlCellTypeLastCell).End(xlDown).Row
    'MaxSheetrows = 65535
End Function

Private Function TransposeSingledimension(ByVal MyVar As Variant) As Variant
'to prevent Excel from reaching the built-in transpose limit
Dim i As Long
Dim vTranspose As Variant
ReDim vTranspose(UBound(MyVar), 0)
For i = LBound(MyVar) To UBound(MyVar)
    vTranspose(i, 0) = MyVar(i)
Next i
TransposeSingledimension = vTranspose
End Function

als je eenfoutmelding krijgt, vertel maar welke, zodat ik je verder kan helpen

 

[Toondeboon]

Helemaal super!!
Die werkt prima!!!

Je bent de held van de dag!