VBA: Sum all correlating values from a table together to Cell

[NessPJ]

Hello,

I have a sheet with data obtained from somewhere else using VBA.
I would like to make VBA code to sum, some of these results together if the user has configured which cells relate to each other. For example:

Excel Row Number	Data	Relationship to Row	End Result
10	5		18
11	41		41
12	7		7
13	99		99
14	2	10	2
15	23		23
16	11	10	11
17	56		56
18	20		20

<tbody>
</tbody>

In the example the table has been configured to make Row 14 and Row 16 have a relationship with Row 10 meaning the Data from Rows 10, 14 and 16 is summed together.

Is it possible to do this?
A limitation would be that a Row can only have a single relationship defined (but thats okay).
Inside the entire table, multiple different relationships should be possible though (some could have only 2 rows defined, while others could for example have 8).

I tried to think of a way how to do this, but i get stuck because i think i need to make a new variable in VBA which is automatically created each time a relationship is found, to sum them all up afterwards?
I didn't know how to proceed there with that.

 

[Martvg]

Ohh, well unfortunately I'm unable to get the same error when column M has a #REF! value.

Could you share the (entire) file with me where you get the error?
I assume column M is filled by a different macro, maybe we can change something there?

 

[NessPJ]

This is all of the code that is in the sheet:

Option Explicit
Option Private Module


Public InvoerbestandCheck As Boolean, FinanceSheetCheck As Boolean, WeekKolomCheck As Boolean
Public KPIPad As String, KPIFile As String, FinanceSheet As String, FinanceSheetKolom As String
Public ShtSel As Worksheet
Public Check As Integer
Public strPath As String, strFile As String, strSheet As String, strCell As String, strTable As String, strColumn As String, strTarget As String, strFormula As String


Sub DataOphalen()


START:


'On Error GoTo Einde


Application.ScreenUpdating = True       'Switch to False when routine works correctly.
Application.DisplayAlerts = False


Call PROTOFF


Call Validatie




    If Check <> 0 Then
    MsgBox "De VBA Code is niet volledig door de validatie heen gekomen. De bewerking wordt afgebroken.", vbCritical, "Bewerking afgebroken"
    GoTo Einde
    End If




Call GegevensOphalen


Call Timestamp


Einde:


'Call PROTON
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub


Sub Validatie()


    'Controleren of het Invoerbestand en de doelgegevens bestaan:
       
    KPIPad = ThisWorkbook.Sheets("Parameters").Range("B4").Value
    KPIFile = ThisWorkbook.Sheets("Parameters").Range("B5").Value
    FinanceSheet = ThisWorkbook.Sheets("Parameters").Range("B10").Value
    FinanceSheetKolom = ThisWorkbook.Sheets("Parameters").Range("B11").Value
        
    If KPIPad = "" Or KPIFile = "" Then
    MsgBox "De waarde voor de KPI/Facturatie Inputfile is nog niet aanwezig of kon niet worden gevonden.", vbExclamation, "Controle Invoerbestand"
    ThisWorkbook.Sheets("Parameters").Range("I4").Value = "Nee"
    InvoerbestandCheck = 1
    Else
    ThisWorkbook.Sheets("Parameters").Range("I4").Value = "Ja"
    InvoerbestandCheck = 0
    End If
    
    If FinanceSheet = "" Then
    MsgBox "De ingestelde Sheet voor de Doellocatie is nog niet aanwezig of kon niet worden gevonden.", vbExclamation, "Controle Doelgegevens"
    ThisWorkbook.Sheets("Parameters").Range("I10").Value = "Nee"
    FinanceSheetCheck = 1
    Else
    ThisWorkbook.Sheets("Parameters").Range("I10").Value = "Ja"
    FinanceSheetCheck = 0
    End If
    
    If FinanceSheetKolom = "" Then
    MsgBox "De ingestelde Kolom voor de Doellocatie is nog niet aanwezig of kon niet worden gevonden.", vbExclamation, "Controle Doelgegevens"
    ThisWorkbook.Sheets("Parameters").Range("I11").Value = "Nee"
    WeekKolomCheck = 1
    Else
    ThisWorkbook.Sheets("Parameters").Range("I11").Value = "Ja"
    WeekKolomCheck = 0
    End If
    
    Check = InvoerbestandCheck + FinanceSheetCheck + WeekKolomCheck
    


    
End Sub


Sub GegevensOphalen()


' Variabelen:
' ===========


Dim sPath As String, sFile As String, sSheet As String, sCell As String, sTable As String, sColumn As String, sTarget As String
Dim TabelRij As Variant, Row As Range, i As Integer, Cell As Range
Dim x As Integer, y As Integer, LastRow As Integer, Smt As Double, errval As Variant




TabelRij = ThisWorkbook.Sheets("Parameters").Range("A65000").End(xlUp).Row


sPath = ThisWorkbook.Sheets("Parameters").Range("B4").Value
sFile = ThisWorkbook.Sheets("Parameters").Range("B5").Value




'
' ===============================================================




' Gegevens ophalen middels VLOOKUP voor iedere regel in de tabel:
' ===============================================================


i = 16


For Each Row In ThisWorkbook.Sheets("Parameters").Range("A16:" & "A" & TabelRij)


sSheet = ThisWorkbook.Sheets("Parameters").Range("H" & i).Value
sCell = ThisWorkbook.Sheets("Parameters").Range("I" & i).Value
sTable = ThisWorkbook.Sheets("Parameters").Range("J" & i).Value
sColumn = ThisWorkbook.Sheets("Parameters").Range("K" & i).Value
sTarget = "M" & i


Call Vlookup(sPath, sFile, sSheet, sCell, sTable, sColumn, sTarget)


i = i + 1


Next


' Opgehaalde formules omzetten naar waardes zodat de sheet snel blijft werken:
' ============================================================================


Sheets("Parameters").Range("M16:M" & TabelRij).Formula = Sheets("Parameters").Range("M16:M" & TabelRij).Value




'De kolom met opgehaalde data wordt doorzocht op #REF! errors en deze worden vervangen met 0
'===========================================================================================
    
    For Each Cell In ThisWorkbook.Sheets("Parameters").Range("M16:M" & TabelRij)
        If Cell.Value = CStr("#REF!") Then
            Cell.Value = 0
        End If
    Next
    


' Relaties van opgehaalde data wordt opgezocht en doorgevoerd naar kolom Eind Resultaat:
' ======================================================================================
    
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow
    
        If IsNumeric(Cells(x, 13)) Then
        Smt = Cells(x, 13).Value
        Else
        GoTo EndLine
        End If
    
    For y = 16 To LastRow
        
        If Cells(y, 14) = x Then
        
        Smt = Smt + Cells(y, 13).Value
        
        End If
        
    Next y
    
    Cells(x, 15).Value = Smt
    
EndLine:
    
    Next x




End Sub


Sub OpenKPIMap()


KPIPad = ThisWorkbook.Sheets("Parameters").Range("B4").Value


Shell "Explorer.exe" & " " & KPIPad, vbNormalFocus


End Sub


Sub KPIBestandKiezen()


Application.DisplayAlerts = False


Call PROTOFF


Dim SelectedFile As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Kies het gewenste KPI Invoerbestand"
.InitialFileName = "U:\NDNL_Tilburg\03_TLB_Operatie\3.1) Customer Service\Customer Service Support Robby\KPI\"


If .Show = -1 Then
'Ok clicked
SelectedFile = .SelectedItems(1)


ThisWorkbook.Sheets("Parameters").Range("B4").Value = GetFoldernameFromPath(SelectedFile)


ThisWorkbook.Sheets("Parameters").Range("B5").Value = GetFilenameFromPath(SelectedFile)
Else
'Cancel clicked
End If


End With


Call PROTON
    
Application.DisplayAlerts = True


End Sub


Sub SelectSheet()


Application.DisplayAlerts = False


Call PROTOFF


Dim cmdBar As CommandBar
Dim cmdBarBtn As CommandBarButton
Dim Sht As Worksheet


RegDel


On Error Resume Next
Set cmdBar = Application.CommandBars.Add("Register", msoBarPopup)
For Each Sht In ThisWorkbook.Worksheets
    Set cmdBarBtn = cmdBar.Controls.Add
    cmdBarBtn.Caption = Sht.Name
    cmdBarBtn.Style = msoButtonCaption
    cmdBarBtn.OnAction = "SelectThatSheet"
Next Sht
cmdBar.ShowPopup
On Error GoTo Einde


'MsgBox "you selected sheet '" & ShtSel.Name & "'"


    If ShtSel.Name = "" Then
    MsgBox "Er is geen Sheet geselecteerd.", vbExclamation, "Controle Invoer geldige Sheet"
    ThisWorkbook.Sheets("Parameters").Range("B10").SetFocus
    Exit Sub
    Else
    ThisWorkbook.Sheets("Parameters").Range("B10").Value = ShtSel.Name
    End If


Einde:


Call PROTON
    
Application.DisplayAlerts = True


End Sub


Sub SelectThatSheet()


Set ShtSel = Worksheets(Application.Caller(1))
RegDel


End Sub


Sub RegDel()


On Error Resume Next
Application.CommandBars("Register").Delete
On Error GoTo 0


End Sub


Sub RangeSelectionPrompt()


Application.DisplayAlerts = False


Call PROTOFF


    Dim rng As Range, KolomL As String, KolomR As String, Kolom As String
    Dim Sht As String
        
    Sht = ThisWorkbook.Sheets("Parameters").Range("B10").Value
    
    ThisWorkbook.Sheets(Sht).Select
        
    On Error Resume Next
    Set rng = Application.InputBox("Kies een Cell in de gewenste uitvoer kolom", "Uitvoer kolom bepalen", Type:=8)
    On Error GoTo Einde


    KolomL = Right(rng.Address, Len(rng.Address) - 1)
    
    KolomR = Mid(KolomL, 1, InStrRev(KolomL, "$") - 1)


    ThisWorkbook.Sheets("Parameters").Range("B11").Value = KolomR
    
Einde:


    ThisWorkbook.Sheets("Parameters").Select


Call PROTON
    
Application.DisplayAlerts = True
    
End Sub


Sub PROTOFF()


    Sheets("Parameters").Unprotect ("12345678")


End Sub


Sub PROTON()


        Sheets("Parameters").Protect DrawingObjects:=True, Contents:=True, AllowUsingPivotTables:=True, Scenarios:=True _
    , AllowFiltering:=True, Password:="12345678"


End Sub


Sub Timestamp()


    If ThisWorkbook.Sheets("Parameters").ProtectContents = False Then
    ThisWorkbook.Sheets("Parameters").Range("I7").Value = Format(Now, "DD-MM-YY HH:MM")
    Else
    Call PROTOFF
    ThisWorkbook.Sheets("Parameters").Range("I7").Value = Format(Now, "DD-MM-YY HH:MM")
    End If


End Sub


Function DoesFileExist(s_directory As String, s_fileName As String) As Boolean


    DoesFileExist = _
        CreateObject("Scripting.FileSystemObject").fileExists(s_directory & "\" & s_fileName)
        
End Function


Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'


    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
    
End Function


Function GetFoldernameFromPath(ByVal strPath As String) As String


  Dim strFullFilePath As String
  strFullFilePath = strPath


  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")


  GetFoldernameFromPath = fso.GetParentFolderName(strFullFilePath) & "\"


End Function


Sub Vlookup(strPath As String, strFile As String, strSheet As String, strCell As String, strTable As String, strColumn As String, strTarget As String)


Dim strFormula As String


    If strPath = "" Or strFile = "" Or strSheet = "" Or strCell = "" Or strTable = "" Or strColumn = "" Or strTarget = "" Then
    strFormula = "#ERR"
    Else
    strFormula = "=VLOOKUP(""" & strCell & """,'" & strPath & "[" & strFile & "]" & strSheet & "'!" & strTable & "," & strColumn & ",0)"
    End If
    
    ThisWorkbook.Sheets("Parameters").Range(strTarget).Formula = strFormula
    
End Sub

Perhaps the problem is that i turn the Formula #REF! errors into values first?
If so, VBA seems to stumble on the fact that the error cell is no longer a formula but a value.
(Then again...if thats the case, wouldn't it just work to find the text value called "#REF!" and replace that?).

 

[NessPJ]

I got it!

I had to replace Cell.Value = CVErr(xlErrRef) to Cell.Text = "#REF!"

For Each Cell In ThisWorkbook.Sheets("Parameters").Range("M16:M" & TabelRij)        If Cell.Text = "#REF!" Then
            Cell.Value = 0
        End If
    Next

 

[NessPJ]

One more question:

If i apply this code with or without Step 1, every other cell seems to be processed while to others don't seem to be. Any idea how this could happen?
I ran into 4 consecutive #N/A's in my column which all should be replaced by 0. Only the 1st and 3rd Row seem to be replaced as expected, even when i use "Step 1" in the code.

Here's my code:

Dim rx As Integer


TabelRij = ThisWorkbook.Sheets("Parameters").Range("A65000").End(xlUp).Row


'De kolom met opgehaalde data wordt doorzocht op errors en deze worden vervangen met 0
'===========================================================================================


    For rx = 16 To TabelRij Step 1
    
    'For Each Cell In ThisWorkbook.Sheets("Parameters").Range("M16:M" & TabelRij)
        If ThisWorkbook.Sheets("Parameters").Range("M" & rx).Text = "#REF!" Then
            ThisWorkbook.Sheets("Parameters").Range("Q" & rx).Value = "#REF!"
            ThisWorkbook.Sheets("Parameters").Range("M" & rx).Value = 0
        End If
        
        If ThisWorkbook.Sheets("Parameters").Range("M" & rx).Text = "#N/A" Then
            ThisWorkbook.Sheets("Parameters").Range("Q" & rx).Value = "#N/A"
            ThisWorkbook.Sheets("Parameters").Range("M" & rx).Value = 0
        End If
        
        rx = rx + 1
        
    Next

Here's a screenshot of the situation (end result):
http://i.imgur.com/CUfaXvO.jpg

 

[Martvg]

One more question:

If i apply this code with or without Step 1, every other cell seems to be processed while to others don't seem to be. Any idea how this could happen?
I ran into 4 consecutive #N/A's in my column which all should be replaced by 0. Only the 1st and 3rd Row seem to be replaced as expected, even when i use "Step 1" in the code.

Here's my code:

Dim rx As Integer


TabelRij = ThisWorkbook.Sheets("Parameters").Range("A65000").End(xlUp).Row


'De kolom met opgehaalde data wordt doorzocht op errors en deze worden vervangen met 0
'===========================================================================================


    For rx = 16 To TabelRij Step 1
    
    'For Each Cell In ThisWorkbook.Sheets("Parameters").Range("M16:M" & TabelRij)
        If ThisWorkbook.Sheets("Parameters").Range("M" & rx).Text = "#REF!" Then
            ThisWorkbook.Sheets("Parameters").Range("Q" & rx).Value = "#REF!"
            ThisWorkbook.Sheets("Parameters").Range("M" & rx).Value = 0
        End If
        
        If ThisWorkbook.Sheets("Parameters").Range("M" & rx).Text = "#N/A" Then
            ThisWorkbook.Sheets("Parameters").Range("Q" & rx).Value = "#N/A"
            ThisWorkbook.Sheets("Parameters").Range("M" & rx).Value = 0
        End If
        
        rx = rx + 1
        
    Next

Here's a screenshot of the situation (end result):
http://i.imgur.com/CUfaXvO.jpg

Hi NessPJ,

You start your loop with

"For rx = 16 To TabelRij Step 1"

And end with

"rx = rx + 1

Next"

What happens in the end is that you add 1 to rx, followed by the next statement. Next adds one to rx to as you specified to loop from rx to tablerij.
Thus going from rx = 16 to rx =17 (due to rx = rx +1) to rx = 18 (due to next) within one loop, practically skipping rx = 17.

Simply deleting the line rx = rx + 1 should solve your problem.

 

[NessPJ]

Silly of me! Thanks for the explanation again.

 

[NessPJ]

Hello Mart,

One more question: I adapted your code for copying values to another sheet...for some reason the code is terribly slow (like 5-8 seconds per Row it handles).

Is there any reason for the code to be so slow?

Here's what i am using:

Public FinanceSheet As String, FinanceSheetKolom As String

Sub GegevensWegschrijven()



' Variabelen:
' =======


Dim x As Integer, y As Integer, LastRow As Integer, Smt As Double

    FinanceSheet = ThisWorkbook.Sheets("Parameters").Range("B10").Value
    FinanceSheetKolom = ThisWorkbook.Sheets("Parameters").Range("B11").Value



' In de tabel met data op de Sheet Parameters wordt nu de geconfigureerde Doelregel opgezocht en de bijbehorende waarde wordt daar naartoe geschreven:
' ==================================================================================================


LastRow = Sheets("Parameters").Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow


        If IsNumeric(Cells(x, 7)) Then
        Smt = Cells(x, 15).Value
        y = Cells(x, 7).Value
        Else
        GoTo EndLine
        End If


    Sheets(FinanceSheet).Range(FinanceSheetKolom & y).Value = Smt




EndLine:


    Next x


End Sub

 

[NessPJ]

I fixed it!

I found out that the target sheet had some underlying calculations which seemed to be running after every For.
I disabled automatic calculation before executing the routine now and re-enable it when the routine has finished using:

Application.Calculation = xlManual

Application.Calculation = xlAutomatic

Now the routine finished ~500 rows in approximately 10 seconds.