Help met VBA code om te grouperen

[Delfo]

Ik heb hulp nodig met een stukje VBA code dat een set Data van mij kan grouperen per leverancier
Ik heb dus een set data waarbij alles in de regels staat (artikel, leverancier, barcode enz.) en ik moet deze in een andere sheet plaatsen en grouperen per leverancier. Ik wil dan per leverancier een lege regel, waarna der artikel regels van die leverancier er onder geplaatst worden.

Zo ziet het eruit aan het begin:


Zo moet het er uiteindelijk uitzien:


Kleuren/links en deregelijke lukken me allemaal, het gaat puur om het grouperen per leverancier

Ik hoop dat iemand mij hier mee kan helpen.

Gr,
Nick

[MrSenne]

Misschien kan je ook even de code die je al hebt posten? Dan kunnen we daarop verderwerken.

[tritimee]

kun je niet een separate lijst aanmaken met al je leveranciers (Pivot?) en dan een for each uit die lijst doen?

[Delfo]

Hier heb ik de code die het in de lay-out krijgt zoals ik wil, alleen niet het group by


Public Sub Convert_To_Hyperlinks()
Dim Cell As Range
Dim rng As Range
Dim CL As Range

Set rng = Range("W15:W13000")
For Each Cell In rng
If Cell <> "" Then
ActiveSheet.Hyperlinks.Add Cell, Cell.Value
End If
Next
End Sub


Sub InsertHyperlinkToText()
'On Error GoTo ExitSub

Application.ScreenUpdating = False

Dim rngActive As Range
Dim currentRow As Integer
Dim strHyperLink As String
Dim Cell As Range
Dim rng As Range

'Set rngActive = ActiveCell
'currentRow = rngActive.Row

'Haal hyperlink op
'strHyperLink = Cells(currentRow, Range("LabHyperlink").Column).Value
'strHyperLink = Cells(Range("Y15:Y12000").Column).Value
Range("A15").Select


'Voeg nu de hyperlink toe
Set rng = Range("B15:B13000")
For Each Cell In rng
Set rngActive = ActiveCell
currentRow = rngActive.Row
strHyperLink = Cells(currentRow, Range("W15:W13000").Column).Value
If Len(strHyperLink) > 0 Then
Dim wks As Worksheet
Set wks = ActiveWorkbook.ActiveSheet
wks.Hyperlinks.Add Anchor:=Cells(currentRow, Range("B15:B13000").Column), Address:=strHyperLink
ActiveCell.Offset(1, 0).Select
End If
Next
Exit Sub:
rngActive.Select
Application.ScreenUpdating = True
Set rngActive = Nothing

End Sub

Sub KopierenPlakkenWaardes()
'
' KopierenPlakkenWaardes Macro
'

'
Sheets("Nalods Layout").Select
Sheets("Nalods Layout").Copy After:=Sheets(2)
Cells.Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A15").Select
End Sub
Sub NaarNieuwBlad()
'
' NaarNieuwBlad Macro
'

'

Sheets("Nalods Layout (2)").Select
Sheets("Nalods Layout (2)").Move
ActiveWindow.ScrollColumn = 3
Columns("W:AD").Select
Selection.ClearContents
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub

Sub RegelsDoortrekken1to4000()
'
' Macro3 Macro
'

Sheets("Nalods Layout").Select
Range("A15:W15").Select
Selection.AutoFill Destination:=Range("A15:W4000"), Type:=xlFillDefault
Range("A15:W4000").Select
End Sub
Sub RegelsDoortrekken4001to8000()
'
' Macro3 Macro
'

'
Range("A4000:W4000").Select
Selection.AutoFill Destination:=Range("A4000:W8000"), Type:=xlFillDefault
Range("A4000:W8000").Select
End Sub
Sub RegelsDoortrekken8001to12000()
'
' Macro3 Macro
'

'
Range("A8000:W8000").Select
Selection.AutoFill Destination:=Range("A8000:W12000"), Type:=xlFillDefault
Range("A8000:W12000").Select
End Sub

Sub RegelsDoortrekken12001to13000()
'
' Macro3 Macro
'

'
Range("A12000:W12000").Select
Selection.AutoFill Destination:=Range("A12000:W13000"), Type:=xlFillDefault
Range("A12000:W13000").Select
End Sub


Sub Button()
'
' Button Macro

Application.ScreenUpdating = False
On Local Error Resume Next
Application.Run "'Exsion.xlam'!MENU_DATA"
On Local Error GoTo 0
Call RegelsDoortrekken1to4000 'macro 2
Call RegelsDoortrekken4001to8000 'macro 3
Call RegelsDoortrekken8001to12000
Call RegelsDoortrekken12001to13000
Call KopierenPlakkenWaardes
Call Convert_To_Hyperlinks
Call InsertHyperlinkToText
Call NaarNieuwBlad
Call PuntenNaarKomma
Application.ScreenUpdating = True

End Sub

Sub PuntenNaarKomma()
'
' PuntenNaarKomma Macro
'

'
Columns("L:P").Select
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select

'Update 20141112
Dim Path As String
Dim filename As String
Path = "\\vsjav01\Data\10 Algemeen\EXSION FR\MacroFiles\SafeFile\"
filename = Range("A1")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs filename:=Path & filename & ".xls", FileFormat:=xlNormal
Application.DisplayAlerts = True


End Sub

[Glewellyn]

Plaats je code even tussen [code] tags

[dix-neuf]

Je twee afbeeldingen bevatten totaal verschillende gegevens (ik zie geen enkele kop die overeenkomt) .Het is dan uiteraard onmogelijk om uit de gegevens van de eerste afbeelding het tweede overzicht samen te stellen.
Verder zou het handig zijn als je de rijnummers en kolomletters had meegekopieerd.

[ Voor 16% gewijzigd door dix-neuf op 07-11-2019 16:16 ]