21. november 2007 - 07:58Der er
23 kommentarer og 1 løsning
Hjælp til ekstra funktion i makro
Hej jeg har tidligere fået hjælp til en makro der afstemmer en finans konto. Og den kører perfeckt. Makroen gør bl.a det at den overstreger beløb der matcher hinanden i samme valuta i kolonne E. Det jeg ønsker er at når alle beløb der matcher er gennem streget skal de ikke gennem streget beløb skifte farve så de er røde .(Det er kun beløb i Kolonne E det omhandler ). Her er makroen. Public Sub FiltreringAfPosteringer()
' Bemærk: Nedenstående er konstanter, og rutinen ' kræver derfor at data er placeret et konkret sted Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Dim I As Integer, j As Integer Dim DebetBeløb As Double, KreditBeløb As Double
' Løb beløbskolonnen igennem fra start til slut For I = StartRække + 1 To SlutRække ' Gem beløb DebetBeløb = Range(BeløbsKolonne & I).Value ' Hvis det er et debetbeløb If DebetBeløb > 0 Then ' Løb beløbskolonnen igennem en gang til og ' led efter kreditbeløb For j = StartRække + 1 To SlutRække KreditBeløb = Range(BeløbsKolonne & j).Value If KreditBeløb < 0 And _ Range("D" & I).Value = Range("D" & j).Value Then
' Hvis debetbeløb og kreditbeløb er ens (+/-) ' og kreditbeløbet ikke tidligere er overstreget
If DebetBeløb = KreditBeløb * -1 And _ Not Range(BeløbsKolonne & j).Font.Strikethrough Then ' Overstreg både debet- og kreditbeløb ' og hop ud af løkke Range(BeløbsKolonne & I).Font.Strikethrough = True Range(BeløbsKolonne & j).Font.Strikethrough = True Exit For End If
' Bemærk: Nedenstående er konstanter, og rutinen ' kræver derfor at data er placeret et konkret sted Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Dim I As Integer, j As Integer Dim DebetBeløb As Double, KreditBeløb As Double
' Løb beløbskolonnen igennem fra start til slut For I = StartRække + 1 To SlutRække ' Gem beløb DebetBeløb = Range(BeløbsKolonne & I).Value ' Hvis det er et debetbeløb If DebetBeløb > 0 Then ' Løb beløbskolonnen igennem en gang til og ' led efter kreditbeløb For j = StartRække + 1 To SlutRække KreditBeløb = Range(BeløbsKolonne & j).Value If KreditBeløb < 0 And _ Range("D" & I).Value = Range("D" & j).Value Then
' Hvis debetbeløb og kreditbeløb er ens (+/-) ' og kreditbeløbet ikke tidligere er overstreget
If DebetBeløb = KreditBeløb * -1 And _ Not Range(BeløbsKolonne & j).Font.Strikethrough Then ' Overstreg både debet- og kreditbeløb ' og hop ud af løkke Range(BeløbsKolonne & I).Font.Strikethrough = True Range(BeløbsKolonne & j).Font.Strikethrough = True Exit For else Range(BeløbsKolonne & I).font.ColorIndex = 3 Range(BeløbsKolonne & j).font.ColorIndex = 3 end if
Den er ikke hel god den gør følgende. Den laver alle røde i kolonne E (både beløb der er overstreget og beløb der ikke er overstreget røde. Mærkeligt gør den ikke E2,E7,og E9 ikke røde sevl om de er overstreget. Mvh petert
ellers kan det være du skal sende mig et ark, jeg kan teste det på
Public Sub FiltreringAfPosteringer()
' Bemærk: Nedenstående er konstanter, og rutinen ' kræver derfor at data er placeret et konkret sted Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Dim I As Integer, j As Integer Dim DebetBeløb As Double, KreditBeløb As Double
' Løb beløbskolonnen igennem fra start til slut For I = StartRække + 1 To SlutRække ' Gem beløb DebetBeløb = Range(BeløbsKolonne & I).Value ' Hvis det er et debetbeløb If DebetBeløb > 0 Then ' Løb beløbskolonnen igennem en gang til og ' led efter kreditbeløb For j = StartRække + 1 To SlutRække KreditBeløb = Range(BeløbsKolonne & j).Value If KreditBeløb < 0 And _ Range("D" & I).Value = Range("D" & j).Value Then
' Hvis debetbeløb og kreditbeløb er ens (+/-) ' og kreditbeløbet ikke tidligere er overstreget
If DebetBeløb = KreditBeløb * -1 And _ Not Range(BeløbsKolonne & j).Font.Strikethrough Then ' Overstreg både debet- og kreditbeløb ' og hop ud af løkke Range(BeløbsKolonne & I).Font.Strikethrough = True Range(BeløbsKolonne & j).Font.Strikethrough = True Exit For End If End If Next End If Next For I = StartRække + 1 To SlutRække ' sæt gul farve på dem der ikke er overstreget If Not Range(BeløbsKolonne & I).Font.Strikethrough Then Range(BeløbsKolonne & I).Font.ColorIndex = 3 End If Next
Jeg har et tillægs spørgsmål om du har et bud på følgende. Kan man soterer rækkerne således at til slut kommer alle de rækker hvor der er rød i kolonne E til at stå øverst? Eller kan man køre en nu makro der gør dette? Et andet problem er øverst i arket har jeg et område H-j 1-10 hvor der komme nogle saldi samt under dem har jeg nogle knapper. Hvis så der er mange rækker og jeg ruller ned ruller selfølgelig disse knapper og saldi op og uden for synsfeltet har du en ide til hvad man kan gøre for bedre funktionalitet. Det kræver selvfølgelig atjeg sender et ark og tilhørende fil jeg afstemmer. Vil du eller andre give et bud på dette. oplys om jeg skal åbne et nyt spørgsmål. Mvh Petert
Indsæt dette i bunden af koden, Du må altid gerne give ekstra point :o)
Det eneste løsning jeg har på det sidste, er at oprette genvejstaster
tl = 0 For I = StartRække + 1 To SlutRække ' hvis rød tekst flyt til top If Range(BeløbsKolonne & I).Font.ColorIndex = 3 Then Rows(I & ":" & I).Cut Rows(StartRække + tl & ":" & StartRække + tl).Insert Shift:=xlDown tl = tl + 1 End If Next
Jeg glemte en detalje. De kolonner der skal soteres i, er Rækkerne fra 2 og højere og kun i kolonne A til G (fordi jeg har saldi og knapper i H til J række 1 til 10 ) Hvad skal koden så være. Mvh Petert
Hej jlemming jeg sender her også fordi jeg ger skulle have det sidste til at virke inden i morgen formidag
Tak for tilsendte. Det virker fint. ”du er en sand mester” Kan man også gøre det sådan, at den sortering du lavede, kan man også køre separat (som jeg tildeler en knap på lige fod med ”eks overstreg maskerede”. Fordi hvis jeg vælger kør makro (posterne afstemmes, markeres røde, og sorteres. Dette er OK) Derefter markerer jeg enkelte beløb, hvis der er tale om mindre afvigelser og slåfejl. Så ville det være godt at kunne sortere de tilbageværende der ikke er overstreget igen så de står øverst. Så kunne jeg ganske enkelt markere disse og printe en side ud til dokumentation til næste gang.
Jeg vedlægger den sidst reviderede makro. Public Sub FiltreringAfPosteringer()
' Bemærk: Nedenstående er konstanter, og rutinen ' kræver derfor at data er placeret et konkret sted Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Dim I As Integer, j As Integer Dim DebetBeløb As Double, KreditBeløb As Double
' Løb beløbskolonnen igennem fra start til slut For I = StartRække + 1 To SlutRække ' Gem beløb DebetBeløb = Range(BeløbsKolonne & I).Value ' Hvis det er et debetbeløb If DebetBeløb > 0 Then ' Løb beløbskolonnen igennem en gang til og ' led efter kreditbeløb For j = StartRække + 1 To SlutRække KreditBeløb = Range(BeløbsKolonne & j).Value If KreditBeløb < 0 And _ Range("D" & I).Value = Range("D" & j).Value Then
' Hvis debetbeløb og kreditbeløb er ens (+/-) ' og kreditbeløbet ikke tidligere er overstreget
If DebetBeløb = KreditBeløb * -1 And _ Not Range(BeløbsKolonne & j).Font.Strikethrough Then ' Overstreg både debet- og kreditbeløb ' og hop ud af løkke Range(BeløbsKolonne & I).Font.Strikethrough = True Range(BeløbsKolonne & j).Font.Strikethrough = True Exit For End If End If Next End If Next For I = StartRække + 1 To SlutRække ' sæt gul farve på dem der ikke er overstreget If Not Range(BeløbsKolonne & I).Font.Strikethrough Then Range(BeløbsKolonne & I).Font.ColorIndex = 3 End If Next tl = 0 For I = StartRække + 1 To SlutRække ' hvis rød tekst flyt til top If Range(BeløbsKolonne & I).Font.ColorIndex = 3 Then Range("A" & I & ":G" & I).Cut Range("A" & StartRække + tl + 1).Insert Shift:=xlDown tl = tl + 1 End If Next
' Bemærk: Nedenstående er konstanter, og rutinen ' kræver derfor at data er placeret et konkret sted Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Dim I As Integer, j As Integer Dim DebetBeløb As Double, KreditBeløb As Double
' Løb beløbskolonnen igennem fra start til slut For I = StartRække + 1 To SlutRække ' Gem beløb DebetBeløb = Range(BeløbsKolonne & I).Value ' Hvis det er et debetbeløb If DebetBeløb > 0 Then ' Løb beløbskolonnen igennem en gang til og ' led efter kreditbeløb For j = StartRække + 1 To SlutRække KreditBeløb = Range(BeløbsKolonne & j).Value If KreditBeløb < 0 And _ Range("D" & I).Value = Range("D" & j).Value Then
' Hvis debetbeløb og kreditbeløb er ens (+/-) ' og kreditbeløbet ikke tidligere er overstreget
If DebetBeløb = KreditBeløb * -1 And _ Not Range(BeløbsKolonne & j).Font.Strikethrough Then ' Overstreg både debet- og kreditbeløb ' og hop ud af løkke Range(BeløbsKolonne & I).Font.Strikethrough = True Range(BeløbsKolonne & j).Font.Strikethrough = True Exit For End If End If Next End If Next For I = StartRække + 1 To SlutRække ' sæt gul farve på dem der ikke er overstreget If Not Range(BeløbsKolonne & I).Font.Strikethrough Then Range(BeløbsKolonne & I).Font.ColorIndex = 3 End If Next Call sortere
End Sub
Sub sortere()
Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Application.ScreenUpdating = False tl = 0 For I = StartRække + 2 To SlutRække ' hvis rød tekst flyt til top If Range(BeløbsKolonne & I).Font.ColorIndex = 3 Then Range("A" & I & ":G" & I).Cut Range("A" & StartRække + tl + 1).Insert Shift:=xlDown tl = tl + 1 End If Next Application.ScreenUpdating = True
Hej igen jeg kan ikke få den sidste makro til at køre rigtigt. Jeg har indsat i en ny makro
Sub sortere()
Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Application.ScreenUpdating = False tl = 0 For I = StartRække + 2 To SlutRække ' hvis rød tekst flyt til top If Range(BeløbsKolonne & I).Font.ColorIndex = 3 Then Range("A" & I & ":G" & I).Cut Range("A" & StartRække + tl + 1).Insert Shift:=xlDown tl = tl + 1 End If Next Application.ScreenUpdating = True
End Sub
men hvis jeg først kører afstemnings, sorterings makroen og jeg så manuelt overstreger eks 4 nye røde poster og så kører soter igen bliver disse 4 nye ikke flyttet ned således at det kun er ikke overstreget der står øverst. har du en ide til hvad der skal rettes i koden /Petert
Hej igen Kan det være noget med der i koden står " hvis rød tekst flyt til top " Når jeg overstreger manuelt forbliver teksten rød men overstreget. Kan det være fejlen? /petert
Hej jlemming igen jeg har idag i mellemtiden prøvet og få løst det sidste omkring afstemningsarket, i spørgsmål 807025 men vi kan ikke få dette til at virke. Jeg tænkte hvis vi ændrede koden i overstregning så den også lavede farven blå og koden i ophævoverstregning så den ændrede farven til sort så vil din kode virke. og så vil jeg kunne se forskel på dem der overstregse automatisk og dem jeg selv overstreger. Kan du få koderne til at virke?? /petert
Sub GennemstregMarkerede() Selection.Font.Strikethrough = True Selection.Font.ColorIndex = 5 End Sub
Sub FjernGennemstregMarkerede() Selection.Font.Strikethrough = False Selection.Font.ColorIndex = xlAutomatic End Sub
Denne Kode flytter dem der ikke er overstreget til toppen Sub sortere()
Const BeløbsKolonne As String = "E" Const StartRække As Integer = 1 Const Regneark As String = "Ark1"
' Find sidste række Sheets(Regneark).Select Dim SlutRække As Integer SlutRække = Range(BeløbsKolonne & StartRække) _ .CurrentRegion.Rows.Count + StartRække - 1
Application.ScreenUpdating = False tl = 0 For I = StartRække + 2 To SlutRække ' hvis ej overstreget tekst flyt til top If Range(BeløbsKolonne & I).Font.Strikethrough = False Then Range("A" & I & ":G" & I).Cut Range("A" & StartRække + tl + 1).Insert Shift:=xlDown tl = tl + 1 End If Next Application.ScreenUpdating = True
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.
