Option Explicit
Private Const ERR_CUSTOM = 666
Private Const APP = "Delegate.nl"
Private mcolKP As Collection
'Transformeer de inputgegevens naar de gewenste indeling
Public Sub TransformeerData()
Dim rCell As Range
On Error GoTo ErrH
'Vraag bevestiging
If MsgBox("Zeker weten?", vbQuestion + vbYesNo, APP) = vbNo Then Exit Sub
Application.ScreenUpdating = False
'Initialisatie-acties
InitializeKP
ShOutput.Cells.ClearContents
ShOutput.Range("A1:C1") = Array("GB", "KP", "Bedrag")
'Bepaal start-cel
Set rCell = GetNamedRange("Start_GB")
'Loop door alle GB-waarden
Do While Not IsEmpty(rCell) And IsNumeric(rCell)
Call PrintData(rCell)
Set rCell = rCell.Offset(rowoffset:=1)
Loop
'Toon getransformeerde data
ShOutput.Activate
MsgBox "Klaar!", vbInformation, APP
CleanUp:
Set mcolKP = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrH:
'Foutafhandeling
Application.ScreenUpdating = True
Select Case Err.Number
Case ERR_CUSTOM
MsgBox Err.Description, vbInformation, APP
Case Else
MsgBox "Onverwachte fout:" & vbCr & Err.Description, vbExclamation
End Select
Resume CleanUp
End Sub
'Schrijf de gegevens weg in tab output
Private Sub PrintData(rCellSource As Range)
Dim rCellTarget As Range
Dim i As Integer
'Bepaal start-cel
Set rCellTarget = ShOutput.Cells(Rows.Count, 1).End(xlUp)
'Print per KP-waarde
For i = 1 To mcolKP.Count
Set rCellTarget = rCellTarget.Offset(rowoffset:=1)
With rCellTarget
.Offset(ColumnOffset:=0) = rCellSource
.Offset(ColumnOffset:=1) = mcolKP(i)
.Offset(ColumnOffset:=2) = rCellSource.Offset(ColumnOffset:=i)
End With
Next
End Sub
'Retourneer een collectie-object met KP's
Private Sub InitializeKP()
Dim rCell As Range
Set mcolKP = New Collection
'Bepaal start-cel
Set rCell = GetNamedRange("Start_KP")
'Loop door alle KP-waarden
Do While Not IsEmpty(rCell) And IsNumeric(rCell)
mcolKP.Add rCell.Value
Set rCell = rCell.Offset(ColumnOffset:=1)
Loop
End Sub
'Retourneer een bereik o.b.v. de bereiknaam
Private Function GetNamedRange(sName As String) As Range
Dim bFound As Boolean
Dim nName As Name
For Each nName In ThisWorkbook.Names
If nName.Name = sName Then
bFound = True
Exit For
End If
Next
If bFound Then
Set GetNamedRange = ThisWorkbook.Names(sName).RefersToRange
Else
Err.Raise ERR_CUSTOM, , "De bereiknaam " & sName & " is niet aangetroffen!"
End If
End Function
