29. juli 2008 - 12:30
Der er
3 kommentarer og
1 løsning
Automatisk ændring af tal i én kolonne
Jeg ønsker mulighed for at kunne prioritere forskellige opgaver i et større regneark med ordrenumre. (PT er der ca. 1300 rækker, som vil stige)
Jeg ønsker at kunne prioritere med tallene 1 - 20, og på en måde så: Ved fx ny prioritet 6, ændres prioriterne 7 - 20 med +1. Samtidigt skal prioritet 1 slettes, når der markeres i en celle på samme række, og samtidigt skal 2 blive til 1 3 til 2 osv.
Jeg ønsker at denne "samme" kode kan stå i alle celler i kolonen, så det kun bliver nødvendigt at lave manuel prioriteringer 1. gang. Herefter håber jeg på et system der løbende automatisk altid har prioriteringen 1-20 synlig for alle.
Rækkerne er inddelt med ca 20 for hver uge, de 20 prioriteringer vil ca dække 3 uger altså ca 60 rækker.
Rækker før vil være produceret (har været 1. prioritet)
Rækkerne efter er endnu ikke prioriteret
PFT
Mvh
Ups
Version 1:
Dim flag As Boolean, ptPrio
Private Sub Worksheet_Activate()
flag = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim nyPrio, nyPrioRæk
On Error GoTo goon
If Not Intersect(Target, Range("K:K")) Is Nothing Then
Rem Hvis x sættes i Kolonne K/11 & prioritet i denne række = 1 (kolonne C/3), så ophæv 1. prio & omnummerer
If Target.Column = 11 And Target.Value = "x" And Target.Offset(0, -8) = 1 Then
flag = True
ophævPrio1 Target.Row
flag = False
End If
Else
If Not Intersect(Target, Range("C:C")) Is Nothing And flag = False Then
Rem ny numerisk værdi indtastes i kolonne C
If Target.Value <> "" And IsNumeric(Target.Value) = True And flx = False Then
Rem Hvis prioritetsNr ændres
flag = True
nyPrio = Target.Value
nyPrioRæk = Target.Row
ændringAfPrio nyPrio, nyPrioRæk
flag = False
End If
flag = False
End If
End If
Exit Sub
goon:
End Sub
Private Sub ophævPrio1(prio1Række)
Dim ræk, startRæk
Rem fjern 1. prioritet og omnummerer (tæl een ned) indtil tom celle i kolonne A
Cells(prio1Række, 3) = ""
startRæk = findStartRække(prio1Række)
If startRæk > 0 Then
For ræk = startRæk + 1 To 65000
If Cells(ræk, 3) <> "" And IsNumeric(Cells(ræk, 3)) = True Then
Cells(ræk, 3) = Cells(ræk, 3) - 1
Else
If Cells(ræk, 1) = "" Then
Exit Sub
End If
End If
Next ræk
Else
MsgBox ("Fejl nedlæg 1. prio. - startrække for prioriteter kunne ikke findes")
End If
End Sub
Private Sub ændringAfPrio(xVærdi, xRække)
Dim ræk, startRæk, startværdi
startRæk = findStartRække(xRække)
startværdi = ptværdi
If startRæk > 0 Then
For ræk = startRæk + 1 To 65000
If Cells(ræk, 3) <> "" And IsNumeric(Cells(ræk, 3)) = True Then
If ræk <> xRække And Cells(ræk, 3) >= xVærdi Then
Cells(ræk, 3) = Cells(ræk, 3) + 1
End If
Else
If Cells(ræk, 1) = "" Then
Exit Sub
End If
End If
Next ræk
Else
MsgBox ("Fejl omnummerering - startrække for prioriteter kunne ikke findes")
End If
End Sub
Private Function findStartRække(xRæk)
Dim ræk
Rem Find hvor prioriteterne begynder (led efter tom celle i kolonne A)
For ræk = xRæk To 1 Step -1
If Cells(ræk, 1) = "" Then
findStartRække = ræk
Exit Function
End If
Next ræk
findStartRække = 0
End Function
