Volgorde van een array zelf kunnen bepalen

[DarkValley]

Beste Vba'ers

Ik probeer zelf de volgorde te bepalen van kopieren van een array naar een nieuw blad. Ik krijg het maar niet voor elkaar.

De code zoekt netjes naar de aangegeven kolommen met de waarde zoals in de Array aangegeven, zo ook de volgorde in declaratie STR is juist. Alleen als dit dan gekopieerd word naar blad "FINAL" neemt hij toch de kolom volgorde over van het origineel. Nu moet ik dus elke keer ervoor zorgen dat de kolommen juist zijn gepositioneerd voordat ik deze code kan gebruiken.

In dit voorbeeld zou in blad "FINAL" dus kolom A, de data van "Menge" moeten bevatten, Kolom B, data van "Pos" en Kolom C, data van "Artikel-Nr"

Zou ik deze array aanpassen naar

 ar = Array("Artikel-Nr", "Pos", "Menge")

dan kolom A, de data van "Artikel-Nr" moeten bevatten, Kolom B, data van "Pos" en Kolom C, data van "Menge" etc.. etc..

Dus ik zoek een manier om via aanpassing "ar" de volgorde te kunnen bepalen en deze volgorde dan over te nemen naar het blad 'FINAL".

Sub Myarr()

Dim ar As Variant

ar = Array("Menge", "Pos", "Artikel-Nr")

Dim r As Range
Dim i As Integer
Dim fn As Range
Dim str As String

' "ar" wordt bepaald per leverancier

For i = 0 To UBound(ar) 'Loop through the Array
 
Set fn = ActiveSheet.Cells(1, 1).EntireRow.Find(ar(i), LookAt:=xlWhole)
 str = str & fn.Address & ","
Next i

'Take the trailing comma from the string
 str = Left(str, Len(str) - 1)
 Set r = Range(str).EntireColumn

 r.Copy Sheets("FINAL").[A1] 'Copy and Paste to "FINAL" sheet in cell A1

Sheets("FINAL").Activate

End Sub

Hoop dat iemand mij kan helpen.


Met vriendelijke groet,

DarkValley

 

[VenA]

Misschien zo?

Sub VenA()
  ar = Array("Menge", "Pos", "Artikel-Nr")
  ar1 = Sheets("Blad1").UsedRange
  For j = 0 To UBound(ar)
    c00 = c00 & " " & Application.Match(ar(j), Sheets("Blad1").Rows(1), 0)
  Next j
  Sheets("FINAL").Cells(1).Resize(UBound(ar1), UBound(ar) + 1) = Application.Index(ar1, Evaluate("Row(1:" & UBound(ar1) & ")"), Split(Mid(c00, 2)))
End Sub

 

[DarkValley]

Beste VenA,

Hierin werkt het perfect. Zal deze even in het originele bestand invoegen. Als het gelukt is dan zal ik vraag als opgelost markeren. Thnx.

 

[DarkValley]

Beste VenA,

Op zich werkt het ook goed binnen de originele code alleen neemt neemt het de huidige cel opmaak niet mee. Is dit gemakkelijk mee te nemen in jouw stukje code?

 

[VenA]

Wil je svp stoppen met quoten? Welke opmaak bedoel je alleen het lettertype en de lijntjes?

 

[DarkValley]

Beste VenA,

Betreffende het quoten. Ik heb geen idee of diegene anders de reactie wel ziet? Vandaar..

@VenA ik bedoel de originele cel opmaak. kan Text of getal zijn?

 

[snb]

Met advancedfilter:

Sub M_snb()
   Blad2.Range("A1:C1") = Array("Menge", "Pos", "Artikel-Nr")
   Blad1.UsedRange.AdvancedFilter 2, , Blad2.Range("A1:C1")
End Sub

met VBA zonder Arrays:

Sub M_snb()
   y = Blad1.UsedRange.Rows.Count
   Blad2.Cells(1).Resize(y, 3) = Application.Index(Blad1.UsedRange, Evaluate("row(1:" & y & ")"), Array(10, 6, 7))
End Sub

 

[DarkValley]

Hi snb,

Probleem is dat de brondata elke keer anders is en ook andere kolomnamen bevat. Wel bedankt voor jouw input:thumb:

 

[OctaFish]

Betreffende het quoten. Ik heb geen idee of diegene anders de reactie wel ziet? Vandaar..

Dat heeft toch niks met quoten te maken? Iedereen ziet altijd alle reacties. Punt. En doe ons een lol, en haal die overtollige quoots nog even weg. Doen niks voor de leesbaarheid van het draadje .

 

[DarkValley]

Zo zal het beter zijn dan. Bedank voor de les "Quoten; ja/nee"

 

[snb]

Probleem is dat de brondata elke keer anders is en ook andere kolomnamen bevat.

Dat geldt dan voor de suggestie van VenA ook.

Dan valt er weinig te automatiseren. Hoe moet de macro weten wat waarin gewijzigd moet worden ?

 

[DarkValley]

Hi snb,

De arrays worden van te voren hardcoded ingesteld in een Case loop. Probleem alleen was dat ik elke keer moest zorgen dat de kolommen op de juiste plaatst stonden om data in de array te lezen. Met oplossing van VenA hoeft dat niet meer alleen als een cijfer combi text is moet deze ook weer text zijn in blad "FINAL" anders haalt Excel voorloop "0" bv weg.

 

[snb]

Heb je überhaupt iets met mijn suggesties gedaan ?

 

[DarkValley]

Was werken, zal zo weer even proberen. Moet het inbouwen in groter geheel. Leek mij meer statisch op eerste gezicht. Ik laat mijn bevindingen weten

 

[DarkValley]

Beste snb,

Even wat meer getest op het bron bestand, helaas zijn beide oplossingen toch te statisch wel nemen ze de cel opmaak mee.

Ik ga verder kijken of ik de cel opmaak mee krijg met de oplossing van VenA

NB. Overigens wel een mooie manier om iets ongelooflijk snel te kopieren naar een ander blad met een filter.:thumb:

 

[VenA]

Ik weet niet hoe je test maar de methode met advancedfilter doet wat jij vraagt. Wat er te statisch aan is begrijp ik niet. De door jou gemaakte array is toch ook statisch? Of begrijp je niet hoe je het moet toepassen als je meer kolommen wil kopiëren?

 

[DarkValley]

@VenA

Nou dat valt wel mee hoor. ik snap dat ik de range dan moet aanpassen en bij de andere manier de waarde 3 naar aantal arrays moet aanpassen en de kolom nummers in array aanpassen. statisch dus want ik moet elke keer weer de code laten aanpassen aangezien dit al gebeurd via "ar" is dat dubbel werk. Probleem is dat ik via een case loop per leverancier in een Array (via ar) aangeef welke data gekopieerd moet worden naar blad FINAL. Dit kunnen dus 3 waarden zijn in een Array maar ook 4, 2 ook staan deze in verschillende kolommen.

De code van @snb werkt perfect alleen niet in mijn geval.

 

[DarkValley]

Ik heb geprobeerd om de code van @VenA zo te maken dat de cell opmaak wordt meegenomen, Mij is het niet gelukt. Dan maar ff verder gegoogeld.



Ik heb een uitbreiding gemaakt op mijn eigen stukje code.

Misschien niet de mooiste oplossing maar het werkt.

Sub Myarr()

Dim ar As Variant

ar = Array("Menge", "Pos", "Bezeichnung1", "Artikel-Nr")

Dim r As Range
Dim i As Integer
Dim fn As Range
Dim str As String

' "ar" wordt bepaald per leverancier

For i = 0 To UBound(ar) 'Loop through the Array
 
Set fn = ActiveSheet.Cells(1, 1).EntireRow.Find(ar(i), LookAt:=xlWhole)
 str = str & fn.Address & ","
Next i

'Take the trailing comma from the string
 str = Left(str, Len(str) - 1)
 Set r = Range(str).EntireColumn

 r.Copy Sheets("FINAL").[A1] 'Copy and Paste to new sheet in cell A1

Sheets("FINAL").Activate

Dim ndx As Integer
Dim Found As Range, counter As Integer

counter = 1

'Application.ScreenUpdating = False

For ndx = LBound(ar) To UBound(ar)

    Set Found = Rows("1:1").Find(ar(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
                      SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

    If Not Found Is Nothing Then
        If Found.Column <> counter Then
            Found.EntireColumn.Cut
            Columns(counter).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
        counter = counter + 1
    End If

Next ndx

'Application.ScreenUpdating = True

End Sub

Als je nu dus de volgorde aanpast in data

ar = Array("Menge", "Pos", "Bezeichnung1", "Artikel-Nr")

ook kolomnamen toevoegen is geen probleem.

Bedankt allemaal voor het meedenken en het aandragen van oplossingen.