24. december 2007 - 14:57Der er
21 kommentarer og 1 løsning
brug af autosum
jeg kører denne
Sub Total()
Application.ScreenUpdating = False ' Undgå at skærm flimrer når der skiftes ark m.v AktuelArk = ActiveSheet.Name: AktuelCelle = ActiveCell.Address ' Husker aktuel ark og celle Set sh1 = Sheets("Total"): sh1.Activate 'sh1 sættes=Ark1, er lettere at skrive flere gange : sh1 aktiveres sh1.Range(Range("D6"), ActiveCell.SpecialCells(xlLastCell)).ClearContents ' Værdier i Ark1 slettes For Each Sh In ActiveWorkbook.Sheets ' Ark løkke starter If Sh.Name <> sh1.Name Then ' Sikrer at Ark1 ikke testes Sh.Activate ' Arkene aktiveres efter tur For t = 7 To Sh.Cells(65000, "G").End(xlUp).Row ' Finder nederste række med værdi i kolonne D If Application.CountIf(sh1.Range("D6:D20000"), Cells(t, "G")) < 1 Then 'Test om aktuel sagsnr. findes i Total sh1.Cells(sh1.Cells(65500, "D").End(xlUp).Row + 1, "D") = Cells(t, "G") 'Skriver sagsnr i Total i næste tomme celle sh1.Cells(sh1.Cells(65500, "E").End(xlUp).Row + 1, "E") = Cells(t, "E") 'Skriver timer i Total i næste tomme celle Else ' Aktuel sagsnummer fantes allerede i Ark1 x = sh1.Range("D6:D20000").Find(Cells(t, "G"), LookIn:=xlValues).Address 'Finder cellen i Total hvor sagsnr er sh1.Range(x).Offset(0, 1) = sh1.Range(x).Offset(0, 1) + Cells(t, "E") ' Timer adderes til aktuel sagsnr End If Next End If Next Sheets(AktuelArk).Select: Range(AktuelCelle).Select 'Oprindelig Ark og celle gøres aktiv igen Application.ScreenUpdating = True ' Skærmopdatering sættes til igen
End Sub
den henter værdier i nogle ark og skriver dem ind i arket "total".
På kolonnen e i "total" laver jeg så en autosum. Det virker ok indtil der kommer en ny indføring af data, så forsvinder min autosum beregning, hvordan undgår jeg det
Hvis du har mulighed for at sende en kopi af din fil, ville det nok være lidt lettere at gennemskue problematikken. Men cellen med AutoSum skal nok indsættes dynamisk - hvis den overskrives.
Application.ScreenUpdating = False ' Undgå at skærm flimrer når der skiftes ark m.v AktuelArk = ActiveSheet.Name: AktuelCelle = ActiveCell.Address ' Husker aktuel ark og celle Set sh1 = Sheets("Total"): sh1.Activate 'sh1 sættes=Ark1, er lettere at skrive flere gange : sh1 aktiveres sh1.Range(Range("D6"), ActiveCell.SpecialCells(xlLastCell)).ClearContents ' Værdier i Ark1 slettes For Each Sh In ActiveWorkbook.Sheets ' Ark løkke starter If Sh.Name <> sh1.Name Then ' Sikrer at Ark1 ikke testes Sh.Activate ' Arkene aktiveres efter tur For t = 7 To Sh.Cells(65000, "G").End(xlUp).Row ' Finder nederste række med værdi i kolonne D If Application.CountIf(sh1.Range("D6:D20000"), Cells(t, "G")) < 1 Then 'Test om aktuel sagsnr. findes i Total sh1.Cells(sh1.Cells(65500, "D").End(xlUp).Row + 1, "D") = Cells(t, "G") 'Skriver sagsnr i Total i næste tomme celle sh1.Cells(sh1.Cells(65500, "E").End(xlUp).Row + 1, "E") = Cells(t, "E") 'Skriver timer i Total i næste tomme celle Else ' Aktuel sagsnummer fantes allerede i Ark1 x = sh1.Range("D6:D20000").Find(Cells(t, "G"), LookIn:=xlValues).Address 'Finder cellen i Total hvor sagsnr er sh1.Range(x).Offset(0, 1) = sh1.Range(x).Offset(0, 1) + Cells(t, "E") ' Timer adderes til aktuel sagsnr End If Next End If Next rk = sh1.Cells(1000, "E").End(xlUp).Row + 1 sh1.Cells(rk, "E").Formula = "=SUM(E6:E" & rk - 1 & ")" Sheets(AktuelArk).Select: Range(AktuelCelle).Select 'Oprindelig Ark og celle gøres aktiv igen Application.ScreenUpdating = True ' Skærmopdatering sættes til igen
Prøv lige at udskifte den kode du har i "ThisWorkbook" modulet med denne :
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Intersect(Target, Sh.Range("A7:G2000")) Is Nothing Then Exit Sub On Error Resume Next If Len(Cells(Target.Row, "G")) = 5 Then Application.EnableEvents = False Call Total Application.EnableEvents = True End If 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.
