13. september 2012 - 11:25Der er
21 kommentarer og 1 løsning
Farv celler mellem to stykker tekst
Hej. Jeg har et regneark der selv udfylder nogle celler med tekst på baggrund af indtastninger i et andet ark. Der er som regel et par cellers mellemrum mellem hver celle med tekst. Jeg vil nu gerne have farvet cellerne mellem to celler med tekst (cellerne med tekst). Hvordan gør jeg det?
Eksempel: I celle a1 står teksten "X", i celle d1 står teksten "Y". Jeg vil gerne have farvet a1:d1.
Jeg har rodet en del rundt med betinget formatering, men syntes ikke helt jeg kunne få det til at se ud som jeg gerne ville. Det jeg mangler at finde ud af er hvordan jeg skriver "Hvis E1=X_Y så skal A1:D1 farves" som en formel eller i VBA. Problemet består nemlig i at jeg har et ark der går fra G4 til AV60, 9 forskellige tekst koder og jeg på forhånd ikke ved hvilke celler (mellem G4:AV60) teksten popper op i.
Nej. Cellerne skal farves vandret (fx A1:d1). Står der fx "P" i cellen A1 og "O" i cellen D1 skal A1:D1 farves. Det besværlige er at jeg ikke ved hvilken kode/bogstav der står i hvilken celle samt hvor langt der er mellem de enkelte celler med indhold.
Yes, der har jeg også været. Problemet er jeg ikke helt kan gennemskue hvordan koden skal se ud for den både tjekker hvad der står i cellerne, beregner afstanden mellem to celler der skal farves og så farver de to celler og alt derimellem.
Synes godt om
Slettet bruger
13. september 2012 - 15:08#7
Vil der altid stå tekst i to kolonner og kun i to. Har det nogen betydning hvilken tekst der står?
Det drejer sig om et område af et regneark der er 42 kolonner bredt og 60 rækker langt, hvor der i alle celler i området kan optræde en tekstkode på en eller to bogstaver. Der er 10 forskellige tekstkoder. I princippet kan alle cellerne være tomme eller alle cellerne kan indholde tekstkode. Det jeg så skal bruge er en makro eller formel til betinget formatering, der skal kunne farvelægge én tekstkode og alle cellerne mellem den celle og den næste celle der indeholder tekst (altså alle tomme celler i mellem). Dette skal kun gøres vandret.
Synes godt om
Slettet bruger
13. september 2012 - 16:21#9
Hvis du vil kan du sende filen til hans.knudsensnabelamail.tele.dk med en klar opgavebeskrivelse og eksempler på ønskede resultater, så skal jeg forsøge.
Sub test() Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells If c.Value = "x" Then Start = c.Address If c.Value = "y" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 3 Start = Empty slut = Empty End If Next c Rk = Rk + 1 Next i End Sub
Eller:
Sub test2() Rk = 4 Dim Svar1 As String Dim Svar2 As String
Svar1 = InputBox("Fra?") Svar2 = InputBox("Til?")
For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells If c.Value = Svar1 Then Start = c.Address If c.Value = Svar2 Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 3 Start = Empty slut = Empty End If Next c Rk = Rk + 1 Next i End Sub
test ser ud til at være noget i den retning. Jeg får dog nok først mulighed for at tjekke den på mandag. Jeg melder tilbage :)
Synes godt om
Slettet bruger
14. september 2012 - 11:19#12
Du skriver:
.. I princippet kan alle cellerne være tomme eller alle cellerne kan indholde tekstkode. Det jeg så skal bruge er en makro eller formel til betinget formatering, der skal kunne farvelægge én tekstkode og alle cellerne mellem den celle og den næste celle der indeholder tekst (altså alle tomme celler i mellem). Dette skal kun gøres vandret.
Hvis, jf. ovenstående, for eksempel A1 indeholder "P" og D1 indeholder "O" hvilket også N1 gør. Er det så området A1:D1 der skal farves eller er det A1:N1?
I sidstnævnte tilfælde kan du bruge denne formel under betinget formatering (for række 1)
Formlen i #12 tester ikke på om der står for eksempel "P", kun på om der står et eller andet. Dette kan selvfølgelig let ændres, men du har jo ikke specificeret noget om, hvad forskellige tekstkoder skal resultere i.
For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells If c.Value = Svar1 Then Start = c.Address If c.Value = Svar2 Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = Svar3 Start = Empty slut = Empty End If Next c Rk = Rk + 1 Next i End Sub
Så er jeg tilbage. Store-Morten, dit svar ser rigtig godt ud, der er dog nogle få problemer. For det første skal jeg ikke bruge tekstboksen, det skal ske automatisk. Helst igennem Worksheet_change.
For det andet så skal den kun farve vandret, altså i rækker. I min test farver funktionen også lodret. Dette opstår sandsynligvis fordi der enkelte steder ikke står et "X" som den første tekstkode eller et "Y" som den sidste.
For det tredje skal jeg bruge fire forskellige farvelægninger. Alle celler der indeholder og ligger mellem P, O og U skal være røde. Alle celler der indeholder og ligger mellem U og A skal være gule. Alle celler der indeholder og ligger mellem PK og K skal være grønne. Og alle celler der indeholder og ligger mellem I, KS og D skal være grå. Dette er igen kun gældende per række.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("G4:AV60"), Target) Is Nothing Then
'U - A = Gul Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "U" Then Start = c.Address If c.Value = "A" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 6 Start = Empty slut = Empty End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'P - O og U = Rød Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "P" Then Start = c.Address If c.Value = "O" Or c.Value = "U" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 3 Start = Empty slut = Empty End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'PK - K = Grøn Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "PK" Then Start = c.Address If c.Value = "K" Or c.Value = "U" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 4 Start = Empty slut = Empty End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'I - KS og D = Grå Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "I" Then Start = c.Address If c.Value = "KS" Or c.Value = "D" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then Range(Start, slut).Interior.ColorIndex = 15 Start = Empty slut = Empty End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
Lidt rettelser U - A = Gul, men farvede også A - U gul. P - O og U = Rød, også modsat. PK - K = Grøn tog PK - U med og farvede grøn, også modsat. I - KS og D = Grå, også modsat.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("G4:AV60"), Target) Is Nothing Then Range("G4:AV60").Interior.ColorIndex = 0
'U - A = Gul Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":Q" & Rk).Cells
If c.Value = "U" Then Start1 = c.Column If c.Value = "U" Then Start = c.Address If c.Value = "A" Then slut1 = c.Column If c.Value = "A" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Start1 < slut1 Then Range(Start, slut).Interior.ColorIndex = 6 Start = Empty slut = Empty End If End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'P - O og U = Rød Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "P" Then Start2 = c.Column If c.Value = "P" Then Start = c.Address If c.Value = "O" Or c.Value = "U" Then slut2 = c.Column If c.Value = "O" Or c.Value = "U" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Start2 < slut2 Then Range(Start, slut).Interior.ColorIndex = 3 Start = Empty slut = Empty End If End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'PK - K = Grøn Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "PK" Then Start3 = c.Column If c.Value = "PK" Then Start = c.Address If c.Value = "K" Then slut3 = c.Column If c.Value = "K" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Start3 < slut3 Then Range(Start, slut).Interior.ColorIndex = 4 Start = Empty slut = Empty End If End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
'I - KS og D = Grå Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "I" Then Start4 = c.Column If c.Value = "I" Then Start = c.Address If c.Value = "KS" Or c.Value = "D" Then slut4 = c.Column If c.Value = "KS" Or c.Value = "D" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Start4 < slut4 Then Range(Start, slut).Interior.ColorIndex = 15 Start = Empty slut = Empty End If End If Next c Start = Empty slut = Empty Rk = Rk + 1 Next i
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("G4:AV60"), Target) Is Nothing Then Range("G4:AV60").Interior.ColorIndex = 0
'U - A = Gul Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "U" Then Kol_U = c.Column If c.Value = "U" Then Start = c.Address If c.Value = "A" Then Kol_A = c.Column If c.Value = "A" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Kol_U < Kol_A Then Range(Start, slut).Interior.ColorIndex = 6 Kol_U = Empty Start = Empty Kol_A = Empty slut = Empty End If End If Next c Kol_U = Empty Start = Empty Kol_A = Empty slut = Empty Rk = Rk + 1 Next i
'P - O og U = Rød Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "P" Then Kol_P = c.Column If c.Value = "P" Then Start = c.Address If c.Value = "O" Or c.Value = "U" Then Kol_O_U = c.Column If c.Value = "O" Or c.Value = "U" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Kol_P < Kol_O_U Then Range(Start, slut).Interior.ColorIndex = 3 Kol_P = Empty Start = Empty Kol_O_U = Empty slut = Empty End If End If Next c Kol_P = Empty Start = Empty Kol_O_U = Empty slut = Empty Rk = Rk + 1 Next i
'PK - K = Grøn Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "PK" Then Kol_PK = c.Column If c.Value = "PK" Then Start = c.Address If c.Value = "K" Then Kol_K = c.Column If c.Value = "K" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If SKol_PK < Kol_K Then Range(Start, slut).Interior.ColorIndex = 4 Kol_PK = Empty Start = Empty Kol_K = Empty slut = Empty End If End If Next c Kol_PK = Empty Start = Empty Kol_K = Empty slut = Empty Rk = Rk + 1 Next i
'I - KS og D = Grå Rk = 4 For i = 1 To 57 For Each c In Range("G" & Rk & ":AV" & Rk).Cells
If c.Value = "I" Then Kol_I = c.Column If c.Value = "I" Then Start = c.Address If c.Value = "KS" Or c.Value = "D" Then Kol_KS_D = c.Column If c.Value = "KS" Or c.Value = "D" Then slut = c.Address If Not Start = Empty And Not slut = Empty Then If Kol_I < Kol_KS_D Then Range(Start, slut).Interior.ColorIndex = 15 Kol_I = Empty Start = Empty Kol_KS_D = Empty slut = Empty End If End If Next c Kol_I = Empty Start = Empty Kol_KS_D = Empty slut = Empty Rk = Rk + 1 Next i
Mange tak for dit svar :) Det virker - næsten! Den mangler stadig at farvelægge nogle steder (fx mellem KS og I, O og BC). Jeg prøver at arbejde lidt videre med det selv. Det skulle være til at finde ud af (håber jeg)
Desuden så virker Worksheet_change åbenbart ikke når ændringen kommer fra en formel der henviser til et andet ark, hvilke jeg ikke lige var klar over. Kan man få Worksheet_change til at farvelægge noget i et andet ark? Jeg har nemlig et data ark (hvor der sker indtastninger) og et "illustrationsark" hvor der skal farvelægges. Mine tekstkoder kommer frem i illustrationsarket på baggrund af indtastninger i dataarket.
Med udgangspunkt i Mortens kode har jeg fundet ud af farvelægning selv. Hvis der er nogen der har en ide til mit worksheet_change problem er de meget velkomne til at skrive :)
Kan man få Worksheet_change til at farvelægge noget i et andet ark? Prøv:
Private Sub Worksheet_Change(ByVal Target As Range)
Ændres til:
Sub farveLæg() 2. linie slettes If Not Intersect(Range("G4:AV60"), Target) Is Nothing Then <-- slettes
'Noget kode
og 2. sidste linie slettes: End If <-- slettes End Sub
Kode på Ark der kalder farveLæg makro:
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Range("G4:AV60"), Target) Is Nothing Then 'ret område til Call Ark1.farveLæg End If End Sub
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.
Slettet bruger
Ny bruger
Nybegynder
Opret
Preview
