05. december 2007 - 22:42Der er
15 kommentarer og 1 løsning
VBA kode til at skrive på statuslinjen
Eksperten Spørgsmål
Jeg er ved at lave et system til at lave vagtplan på min
arbejdsplads. I den forbindelse har jeg ledt efter en eller anden måde at holde
øje med hvad hver enkelt ansats timenorm er, hvor mange timer hver
enkelt har i en rulleplan samt hvor mange timer hver enkelt har i en
udfyldt vagtplan. Det har jeg overhovedet ikke kunnet finde ud af. Så var det jeg kom i tanker om en metode til at overtage
statuslinjen i Excel ved hjælp af VBA. Det kan jo nok bruges til mange ting. Nu bruger jeg det, sådan her, til at vise meddelelser på
statuslinjen når rulleplanen bliver kopieret til vagtplanen:
---------- 'VBA overtager kontrollen med statuslinjen Application.DisplayStatusBar = True 'VBA viser meddelelser i statuslinjen efterhånden som SubRutinen
Jeg får en fejlmelding ved markering af en celle i området på [Uge1] 'Ambigouous name detected: Worksheet_SelectionChange' i linjen 'Private Sub Worksheet_SelectionChange(ByVal Target As Range)'
Kan det være fordi der i forvejen ligger en Sub i arket hvor første linje begynder med 'Private Sub Worksheet_Change(ByVal Target As Excel.Range)'
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 And Target <> "" Then navn = Cells(Target.Row, 1) TN = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 1).Offset(0, 3) RP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 1).Offset(0, 4) VP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 1).Offset(0, 5) Application.StatusBar = navn & " TimeNorm " & TN & " Rulleplan " & RP & " Vagtplantimer " & VP End If If Target.Row = 2 Then Call OpenCalendar End If End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column > 1 And Target.Row > 3 And Target.Column < 37 And Target.Row < 42 And Cells(Target.Row, 1) <> "" Then On Error Resume Next ' hvis navn i uge1 ikke findes i Ansatte navn = Cells(Target.Row, 1) TN = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 4) RP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 5) VP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 6) Application.StatusBar = navn & " TimeNorm " & TN & " Rulleplan " & RP & " Vagtplantimer " & VP End If If Target.Row = 2 And Target.Column > 1 And Target.Column < 7 Then Call OpenCalendar End If End Sub
Nu virker det - sådan da. Det er de rigtige værdier der hentes og min kalenderkontrol virker. Værdierne vises bare forkert. Sådan her skulle de se ud: Per - Timenorm = 148:00 - Rulleplan = 142:30 - Vagtplantimer = 142:30
Ganger jeg tallene med 24 får jeg det korrekte tal, men som decimaltal. Er det muligt at sætte formatet til [t]:mm i statusbaren?
Desuden mangler der noget der kan give kontrollen over statuslinjen tilbage til Excel (altså fjerne værdierne i statuslinjen igen), men det har jeg løst ved at indsætte 'Application.Statusbar = False' et par steder. Det skal jeg nok så gøre først i arkkoden på hvert ark. Koden ser derefter sådan her ud: Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.StatusBar = False If Target.Column > 1 And Target.Row > 3 And Target.Column < 37 And Target.Row < 42 And Cells(Target.Row, 1) <> "" Then On Error Resume Next ' hvis navn i uge1 ikke findes i Ansatte navn = Cells(Target.Row, 1) TN = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 4) RP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 5) VP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 6) Application.StatusBar = navn & " - TimeNorm = " & TN & " - Rulleplan = " & RP & " - Vagtplantimer = " & VP End If If Target.Row = 2 And Target.Column > 1 And Target.Column < 7 Then Application.StatusBar = False Call OpenCalendar End If
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column > 1 And Target.Row > 3 And Target.Column < 37 And Target.Row < 42 And Cells(Target.Row, 1) <> "" Then On Error Resume Next ' hvis navn i uge1 ikke findes i Ansatte navn = Cells(Target.Row, 1) TN = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 4).Text RP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 5).Text VP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 6).Text Application.StatusBar = navn & " TimeNorm " & TN & " Rulleplan " & RP & " Vagtplantimer " & VP End If If Target.Row = 2 And Target.Column > 1 And Target.Column < 7 Then Call OpenCalendar End If End Sub
m.h.t. nustilling af statusbar, så har du fat i det rigtige se her hvad F1-HJÆLP skriver.
This example sets the status bar text to "Please be patient..." before it opens the workbook Large.xls, and then it restores the default text.
Fantastisk. Akkurat som jeg havde tænkt det skulle virke. Bare .Text efter variablerne. Så lidt der skal til når man ved hvordan. Jeg har ændret en lille smule i visningen på statuslinjen og tilføjet en enkelt Application.StatusBar = False. Her er den færdige kode:
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column > 1 And Target.Row > 3 And Target.Column < 37 And Target.Row < 42 And Cells(Target.Row, 1) <> "" Then On Error Resume Next ' hvis navn i uge1 ikke findes i Ansatte navn = Cells(Target.Row, 1) TN = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 4).Text RP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 5).Text VP = Sheets("Ansatte").Cells(Sheets("Ansatte").Range("A4:A41").Find(navn, LookIn:=xlValues).Row, 6).Text Application.StatusBar = navn & " - TimeNorm " & TN & " timer - Rulleplan " & RP & " timer - Vagtplan " & VP & " timer" End If If Target.Row = 2 And Target.Column > 1 And Target.Column < 7 Then Application.StatusBar = False Call OpenCalendar End If End Sub
Nu skal jeg bare have lagt koden i fire andre ark. Så mangler jeg kun at lave en fornuftig udskrift. Tak for hjælpen. Læg et svar.
Nå ja forresten, så ændrede jeg også lige din 'On Error Resume Next' til 'On Error GoTo Blank' og satte dette ind lige før 'End Sub':
Blank: Application.StatusBar = False
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
