22. juli 2010 - 09:44
Der er
5 kommentarer
Søg og indsæt - fortsat
Hej supertekst.
Tak for dit svar i tidligere spg.
Jeg har dog et par yderligere ting som driller, og håber derfor at du vil ofre lidt mere tid på at hjælpe.
Indledningsvis, så har jeg ændret lidt i den formel du lavede, således. at "Beløb" = Det fulde beløb. Dvs. det er ikke bare ændringen (jeg har sat en note i VBA koden, så du kan se hvad jeg mener). Årsagen er, at jeg egentlig regnede med, at det var tilstrækkeligt at se det overordende resultat.
Mit problem er nu, at jeg har behov for også at se hvor ændringen har været. Således kunne jeg godt tænke mig, at kolonne O ligges under "beløb" i personale (Det gør den ved den ændring jeg har lavet i koden), men yderligere, at kolonne N bliver lagt i kolonne V "Ændring" i personale
Jeg har dog I den forbindelse yderligere et problem, nemlig at konto 210100 løn består af tre elementer, nemlig grundløn, resultatløn og tillæg - men de ligger alle på samme overordnede konto. Jeg ville jo egentlig gerne se hvordan fordelingen mellem de tre konti er, men jeg kan ikke ødelægge strukturen i rækkerne under "personale". Er det muligt, at der ud for konto 210100 i personale arket, bliver specificeret, eks. i kolonne X:Z, hvordan lønne er bygget op.
Ekspmelvis: ALM har en løn org. løn på 1125. 1000 er grundløn, 100 er resultatløn og 25 er tillæg. Nu får hun 1000 kr. mere i grundløn 100 mere i reultatløn og 10 kr yderligere i tillæg. Kan macroen så ligge de ændrede beløb ud i hhv. x, y, Z kolonnen ud for 210100? Jeg har prøvet at illustrere i filen.
Din hjælpe betyder rigtig meget, så tak for det.
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
