13. april 2005 - 10:38Der er
7 kommentarer og 1 løsning
Seneste opdateringsdato på forskellige ark
Hejsa...
Jeg har et halv stort excel dokument med en hel del ark. Inde under hver ark skal dags dato stå hver gang man har lavet rettelser på netop det ark. Derudover skal der på det aller første ark (forsiden) være en henvisning til den dato fra de forskellige ark, så man der kan se hvornår det pågældende ark er opdateret sidst.
Jeg har prøvet at bruge idag() funktionen, men laver man en rettelse i et ark bliver datoen ændret i alle ark, inkl. forsiden, og det er jo ikke det jeg er interesseret i.
Det er vigtigt at alle ark ligger i samme dokument men også vigtigt at datoerne ikke bliver opdateret andre steder end på det pågældende ark.
Dim Change As Boolean Dim ChangeSheetName As String
Private Sub Workbook_Open() Change = False ChangeSheetName = "" End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Change = True ChangeSheetName = ActiveSheet.Name End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) If Change Then Sheets(ChangeSheetName).Range("A1") = Date ' sætter dato i A1 på det ark der er ændret, ret til din celle Change = False ChangeSheetName = "" End Sub
sættes i ThisWorkbook modulet.
der skal nok sættes en begrænsning for hovedarket.
hmmm... er vist ikke så god til det med vba... prøver lige at se om jeg har forstået det rigtigt...
Den første kode skal sættes ind i ThisWorkbook - dette virker også, pånær for det første ark (forsiden) På forsiden vil jeg også have dato på hvis der er ting der er ændret, dog ikke hvis det er en af datoerne fra de andre ark der er ændret på... (uh...begynder det nu at blive for kompliceret...??)
(jeg kan godt bruge samme celle på forsiden som på de resterende ark til datoen... det er ikke noget problem...)
håber ikke det bliver alt for kompliceret nu... *S*
det med forsiden, den virker i øjeblikket kun når du skifter imellem ark. du får lige lidt mere kode, så skulle det være i orden
Dim Change As Boolean Dim ChangeSheetName As String
Private Sub Workbook_BeforeClose(Cancel As Boolean) If Change Then Sheets(ChangeSheetName).Range("A1") = Date + Time ' sætter datotid i A1 på det ark der er ændret, ret til din celle Change = False ChangeSheetName = "" End Sub
Private Sub Workbook_Open() Change = False ChangeSheetName = "" End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Change = True ChangeSheetName = ActiveSheet.Name End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) If Change Then Sheets(ChangeSheetName).Range("A1") = Date + Time ' sætter datotid i A1 på det ark der er ændret, ret til din celle Change = False ChangeSheetName = "" End Sub
her er en stor kode, den opretter en forside, som hedder menu.
Den opdateres hvergang mappen åbnes.
Der bliver lavet hyperlink til samtlige sider i din xls fil, og tiden hvornår de er ændret står ved siden af arknavnet.
jeg ved ikke om du kan bruge det, men du skriver en forside, så denne er et alternativ.
det eneste sted du skal ændre er her, hvor du retter K1 til din celle hvor tiden skal stå.
Const AD = "K1" 'sætter datotid i A1 på det ark der er ændret, ret til din celle
Koden skal ligge i ThisWorkbook modulet og erstatter det andet du har fået her.
Dim Change As Boolean Dim ChangeSheetName As String Const AD = "K1" 'sætter datotid i A1 på det ark der er ændret, ret til din celle
Private Sub Workbook_BeforeClose(Cancel As Boolean) If Change Then Sheets(ChangeSheetName).Range(AD) = Date + Time Change = False ChangeSheetName = "" End Sub
Private Sub Workbook_Open() Change = False ChangeSheetName = ""
Dim W As Integer, K As Integer, A As Integer W = 1 ' styrer række inden for hyperlink K = 1 ' styrer kolonner inden for hyperlink For Each ws In Worksheets If ws.Name = "Menu" Then GoTo Findes Next ws
Set NewSheet = Worksheets.Add ' opretter nyt ark, HVIS DET IKKE FINDES NewSheet.Name = "Menu" ' navngiver det nye ark
Findes: Range("A1:J1").MergeCells = False Worksheets("Menu").Activate Range("a2:f31").Select ' sletter alle data i området til hyperlink Selection.ClearContents ' der kan jo være fjernet sider ??? Range("a2").Select '-----------------------------------------Der laves hyperlink til alle ark ------------- For Each ws In Worksheets Worksheets("Menu").Range("a2:a150").Cells(W, K).Select ' reseverer et område til at skrive hyperlink i
If ws.Name = "Menu" Then GoTo Næste ' Hopper over hovedarket "Menu"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1" ActiveCell.FormulaR1C1 = ws.Name ' skriver hyperlink på alle sider inden for området CE = "='" & ws.Name & "'!" & AD ActiveCell.Offset(0, 1).Formula = CE ActiveCell.Offset(0, 1).NumberFormat = "dd/mm/yy hh:mm" W = W + 1 Næste: Next ws '------------------------------Soterer kollonne A ---------------------------- Range("A2:B150").Select Selection.Sort Worksheets("Menu").Columns("A"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select With Selection .HorizontalAlignment = xlCenter End With Selection.Merge With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = 3 End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = 3 End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = 3 End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = 3 End With End If
Range("d30").Select
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Change = True ChangeSheetName = ActiveSheet.Name End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) If Change Then Sheets(ChangeSheetName).Range(AD) = Date + Time Change = False ChangeSheetName = "" End Sub
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.
