Help with database in excell

[Ger]

A few years ago someone inhere created a database for me using excel. It worked fine till now. I have to add the hours spent on the attributes in row 12 to 14.
I tried several things but without result.

Can someone help me to create a working database (using excel).

See attachment.

Thx,

Ger

[jonh]

B9 should read 'Two 2016 deescalerend', not Two 2016 'de-escalerend'.

The text has to match the range names.

[SamT]

@ Jonh :dunno I think Sheets("Input".Range("B9") is just a label for human consumption. However, I've often been know to be wrong.

@ Ger. We need more details please.

Is this the workbook code that was working before?

[jonh]

Maybe. I just clicked the buttons. The clear and save buttons seemed to work ok but load gave a range error.

[Ger]

Till this year i only needed input in range C8 till C18. The activity (named in B8 till B18) was always a full day. Since this year the activity in cells B12 till B14 is in houres.

Cell B9 has indeed a new name. I changed it like jonh suggested.

I succeeded in writing it to the database but i get an error on loading it.

I changed the original code this way (see bolded tekst):

Option Explicit
Option Private Module
Private Const AppId As String = "ContactMomenten"
Public Function DataClear()
With wsInput

.Range("inpNaam").Value = ""
.Range("C8:d18").ClearContents 'changed c18 to d18
End With
End Function
Public Function DataGet()
Dim mpPlnr As Variant
Dim mpDataRow As Long
Dim i As Long
Dim j As Long
With wsInput
.Range("C8:d18").ClearContents 'changed c18 to d18
mpPlnr = .Range("inpPlnr").Value


On Error Resume Next
mpDataRow = Application.Match(mpPlnr, wsDatabase.Columns(1), 0)
On Error GoTo 0
If mpDataRow = 0 Then

MsgBox "Geen gegevens gevonden", vbOKOnly + vbExclamation, AppId
Exit Function
End If

.Range("C8:d18").ClearContents 'changed c18 to d18
.Range("inpNaam").Value = wsDatabase.Cells(mpDataRow, "B").Value

For i = mpDataRow To mpDataRow + Application.CountIf(wsDatabase.Columns(1), mpPlnr) - 1
.Range("inpGerealiseerd" & wsDatabase.Cells(i, "D").Value).Value = wsDatabase.Cells(i, "E").Value
Next i
'Added
For j = mpDataRow To mpDataRow + Application.CountIf(wsDatabase.Columns(1), mpPlnr) - 1
.Range("inpGerealiseerduren" & wsDatabase.Cells(i, "E").Value).Value = wsDatabase.Cells(i, "F").Value
Next j

End With
End Function
Public Function DataPut()
Dim mpPM As Variant
Dim mpPlnr As Variant
Dim mpNaam As Variant
Dim mpDataRow As Long
Dim i As Long
With wsInput
mpPlnr = .Range("inpplnr").Value
mpNaam = .Range("inpNaam").Value
If mpNaam = 0 Then

MsgBox "Eerst naam invullen", vbOKOnly + vbExclamation, AppId
Exit Function
End If
End With

With wsDatabase

mpDataRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For i = mpDataRow To 2 Step -1

If .Cells(i, "A").Value = mpPlnr Then

.Rows(i).Delete
End If
Next i
End With

Call DataAdd

End Function
Public Function DataAdd()
Dim mpPM As Variant
Dim mpPlnr As Variant
Dim mpNaam As Variant
Dim mpDataRow As Long
Dim i As Long
With wsInput

mpPlnr = .Range("inpPlnr").Value
If mpPlnr = 0 Then

MsgBox "Eerst plnr invullen", vbOKOnly + vbExclamation, AppId
Exit Function
End If

mpPM = .Range("inpPM").Value
If mpPlnr = 0 Then

MsgBox "Eerst pm invullen", vbOKOnly + vbExclamation, AppId
Exit Function
End If

mpNaam = .Range("inpNaam").Value
If mpNaam = 0 Then

MsgBox "Eerst naam invullen", vbOKOnly + vbExclamation, AppId
Exit Function
End If

mpDataRow = wsDatabase.Cells(wsDatabase.Rows.Count, "A").End(xlUp).Row + 1
For i = 8 To 18

If .Cells(i, "C").Value <> "" Then

wsDatabase.Cells(mpDataRow, "A").Value = mpPlnr
wsDatabase.Cells(mpDataRow, "B").Value = mpNaam
wsDatabase.Cells(mpDataRow, "C").Value = mpPM
wsDatabase.Cells(mpDataRow, "D").Value = Replace(.Cells(i, "B").Value, " ", "_")
If .Cells(i, "C").Value <> "" Then

wsDatabase.Cells(mpDataRow, "E").Value = .Cells(i, "C").Value
'Added wsDatabase.Cells(mpDataRow, "F").Value = .Cells(i, "D").Value
End If

mpDataRow = mpDataRow + 1
End If
Next i

SortDatabase
End With

End Function

Private Function SortDatabase()
With wsDatabase

.Columns("A:f").Sort key1:=.Range("A1"), order1:=xlAscending, _
key2:=.Range("D1"), order2:=xlAscending, _
header:=xlYes
End With
End Function

[jonh]

Based on the original code


Public Function DataGet()
Dim mpPlnr As Variant
Dim mpDataRow As Long
Dim i As Long


With wsInput
.Range("C8:d18").ClearContents
mpPlnr = .Range("inpPlnr").Value


On Error Resume Next
mpDataRow = Application.Match(mpPlnr, wsDatabase.Columns(1), 0)
On Error GoTo 0
If mpDataRow = 0 Then

MsgBox "Geen gegevens gevonden", vbOKOnly + vbExclamation, AppId
Exit Function
End If

.Range("C8:d18").ClearContents
.Range("inpNaam").Value = wsDatabase.Cells(mpDataRow, "B").Value

For i = mpDataRow To mpDataRow + Application.CountIf(wsDatabase.Columns(1), mpPlnr) - 1
With wsInput.Range("inpGerealiseerd" & wsDatabase.Cells(i, "D"))
.Value = wsDatabase.Cells(i, "E").Value
.Offset(0, 1).Value = wsDatabase.Cells(i, "F").Value
End With
Next i

End With
End Function




Private Function GetVal(v As Variant, s As String) As Boolean
v = wsInput.Range("inp" & s).Value
If Len("" & v) = 0 Then
MsgBox "Eerst " & s & " invullen", vbOKOnly + vbExclamation, AppId
Else
GetVal = True
End If
End Function


Public Function DataAdd()
Dim mpPM, mpPlnr, mpNaam
Dim mpDataRow As Long
Dim i As Long


With wsInput
If Not GetVal(mpPlnr, "plnr") Then Exit Function
If Not GetVal(mpPM, "pm") Then Exit Function
If Not GetVal(mpNaam, "naam") Then Exit Function

mpDataRow = wsDatabase.Cells(wsDatabase.Rows.Count, "A").End(xlUp).Row + 1
For i = 8 To 18

If .Cells(i, "C").Value <> "" Or .Cells(i, "D").Value <> "" Then
With wsDatabase
'id
.Cells(mpDataRow, "A").Value = mpPlnr
.Cells(mpDataRow, "B").Value = mpNaam
.Cells(mpDataRow, "C").Value = mpPM
.Cells(mpDataRow, "D").Value = Replace(wsInput.Cells(i, "B").Value, " ", "_")

'value
.Cells(mpDataRow, "E").Value = wsInput.Cells(i, "C").Value
.Cells(mpDataRow, "F").Value = wsInput.Cells(i, "D").Value
End With

mpDataRow = mpDataRow + 1
End If
Next i
SortDatabase
End With
End Function

[Ger]

Thx.
This works fine for me.

Ger