Hej jean01ad
Vender tilbage senere...
Const lønKontoNr = 210100
Const ændringsOmråde = "N16:N65"
Const detailFarve = 19
Dim arkPersonale As Worksheet
Dim kontonr As Long, initialer As String, beløb As Long, ændring As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$M$12:$O$12" Then
svar = MsgBox("Opdater ændringer?", vbYesNo)
If svar = 6 Then
Set arkPersonale = ActiveWorkbook.Sheets("Personale")
findEvtÆndringer
End If
End If
End Sub
Private Sub findEvtÆndringer()
Dim celle, adr As String, pRæk As Long
Application.ScreenUpdating = False
For Each celle In Range(ændringsOmråde).Cells
If celle.Interior.ColorIndex = detailFarve And _
IsNumeric(celle.Value) = True And celle.Value <> "" Then
adr = celle.Address
kontonr = Range(adr).Offset(0, 2)
initialer = Range("B3")
Rem Jeg har ændret her, så beløb hedder: beløb = Range (adr).Offset (0,1)
beløb = Range(adr).Offset(0, 1)
ændring = Range(adr)
pRæk = findRække(initialer, kontonr)
If pRæk > 0 Then
opdaterPersonaleÆndring pRæk, beløb, ændring
Rem er det lønkonto
If kontonr = lønKontoNr Then
opdaterLønkonto pRæk, Range("O16"), Range("O17"), Range("O18")
End If
Else
MsgBox ("Række i Personale ej fundet vedr.: " & initialer & "/" & CStr(kontonr))
End If
End If
Next celle
pRæk = findFørsteRække(initialer)
opdaterPersonaleIngenÆndringer initialer, pRæk
arkPersonale.Activate
arkPersonale.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Private Function findRække(initialer, kontonr)
Dim ræk As Long, række As String
With arkPersonale
For ræk = 2 To 65126
række = ræk
If .Range("A" & række) <> "" Then
If .Range("B" & række) = initialer And .Range("D" & række) = kontonr Then
findRække = ræk
Exit Function
End If
Else
Exit For
End If
Next ræk
End With
findRække = 0
End Function
Private Sub opdaterLønkonto(ræk, grundLøn, resultatLøn, tilLæg)
Dim række As String
række = ræk
With arkPersonale
.Range("X" & række) = grundLøn
.Range("Y" & række) = resultatLøn
.Range("Z" & række) = tilLæg
End With
End Sub
Private Sub opdaterPersonaleÆndring(ræk, beløb, ændring)
Dim celle, adr As String, række As String
række = ræk
With arkPersonale
For Each celle In .Range("A" & række & ":" & "E" & række).Cells
adr = celle.Address
.Range(adr).Offset(0, 13) = .Range(adr).Value
Next
For Each celle In .Range("G" & række & ":" & "H" & række).Cells
adr = celle.Address
.Range(adr).Offset(0, 13) = .Range(adr).Value
Next
Rem test beløb
If beløb <> 0 Then
.Range("S" & række) = .Range("S" & række) + beløb
.Range("V" & række) = .Range("V" & række) + ændring
End If
End With
End Sub
Private Function findFørsteRække(initialer)
Dim ræk As Long, række As String
With arkPersonale
For ræk = 2 To 65126
række = ræk
If .Range("A" & række) <> "" Then
If .Range("B" & række) = initialer Then
findFørsteRække = ræk
Exit Function
End If
Else
Exit For
End If
Next ræk
End With
findFørsteRække = 0
End Function
Private Sub opdaterPersonaleIngenÆndringer(initialer, ræk1)
Dim celle, adr As String, række As String
For ræk = ræk1 To 65126
række = ræk
With arkPersonale
If .Range("B" & række) = initialer Then
Rem udfyld kun ikke allerede udfyldte rækker
If .Range("N" & række) = "" Then
For Each celle In .Range("A" & række & ":" & "H" & række).Cells
adr = celle.Address
.Range(adr).Offset(0, 13) = .Range(adr).Value
Next
End If
Else
Exit For
End If
End With
Next ræk
End Sub
men du kan få et friskt - ..
