Makro og VBA - Betinget formattering af rækker

Betinget formattering af rækker

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=623
Udskrevet den: 20.Apr.2025 kl. 05:49

Emne: Betinget formattering af rækker

Besked fra: PI
Emne: Betinget formattering af rækker
Posteringsdato: 24.Jan.2012 kl. 19:36

Hej Forum!

Er der nogen som kan kode en komando til at styre et arks rækkehøjde betinget af en værdi i en celle i et andet ark?

Her er et eksempel:

Når G72 i Ark1 = "" skal højden på rækkerne 7:13 = 0.

Når G72 i Ark1 > "" skal højden på rækkerne 7:13 = 12.

Jeg forventer at komandoen skal indsættes i det omhandlende arks VBA.

-------------
Mvh. PI / Excel 2010

Svar:

Besked fra: PI
Posteringsdato: 24.Jan.2012 kl. 19:39

Hej Forum!

Her er eksemplet lidt mere præciseret.

Når G72 i Ark1 = "", skal højden på rækkerne 7:13 i Ark 2 = 0.

Når G72 i Ark1 > "", skal højden på rækkerne 7:13 i Ark 2 = 12.

-------------
Mvh. PI / Excel 2010

Besked fra: rassten
Posteringsdato: 24.Jan.2012 kl. 21:33

Højreklik på det pågældende Ark, vælg "vis programkode"
indsæt kode


Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
 If Target.Address = "$G$72" Then
 
    If Target.Value = "" Then Rows("7:13").RowHeight = 0
    If Target.Value <> "" Then Rows("7:13").RowHeight = 12
 
 End If
 
End Sub

Kode tjekker hele tiden om der er sket noget i celle G72, afhængig om den er tom eller ikke tom skjules rækkerne 7 til 13.
Bemærk at koden vil fejle hvis du eksempelvis slette flere celler hen over celle G72, for så er det ikke celle G72 men et område som der sker noget ved.

-------------
VH rassten

Arbejde excel 2010
Privat excel 2010

Besked fra: PI
Posteringsdato: 25.Jan.2012 kl. 16:52

Hej Rassten

Tak for koden. Jeg har tilrettet og implementeret den som den ser ud nedenfor:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "'STAMDATA'!$G$72" Then

If Target.Value = "-" Then Rows("19:34").RowHeight = 0
If Target.Value <> "-" Then Rows("19:34").RowHeight = 14.25

End If

End Sub

Linjehøjderne bliver imidlertid ikke ændrede i højden. Den eneste effekt koden har er at der forsvinder en af teksterne i en af de rækker som jeg forsøger at formindske. Kan den manglende funktion af koden være forårsaget af at jeg har en version 2003?

-------------
Mvh. PI / Excel 2010

Besked fra: PI
Posteringsdato: 25.Jan.2012 kl. 17:01

Hej Rassten!

Jeg har testet koden, og fundet at den er ok hvis cellereferencen er i samme ark som de rækker som ønskes reguleret i højden.

Jeg må derfor have anført ark+celleferencen ("'Stamdata'!$A$72") med en forkert notation i koden. Kan du hjælpe mig med skrive referencen med den korrekte notation i koden?

-------------
Mvh. PI / Excel 2010

Besked fra: excelent
Posteringsdato: 25.Jan.2012 kl. 18:06

Koden indsættes i arket hvor du ændrer på celle G72

Ret i koden "Ark2" til aktuel arknavn hvor koden skal ændre rækkehøjde

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("G72")) Is Nothing Then Exit Sub
If Target.Value = "-" Then Sheets("Ark2").Rows("19:34").RowHeight = 0
If Target.Value <> "-" Then Sheets("Ark2").Rows("19:34").RowHeight = 14.25
End Sub

Besked fra: PI
Posteringsdato: 25.Jan.2012 kl. 21:15

Hej Excelent!

Koden virker perfekt.

Jeg har imidlertid forsøgt at udbygge den ved at kopiere koden serielt, men det fungerer ikke. Jeg har indkopieret koden nedenfor.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("G41")) Is Nothing Then Exit Sub
If Target.Value = "2" Then Sheets("Fotos").Rows("19:34").RowHeight = 14.25
If Target.Value <> "2" Then Sheets("Fotos").Rows("19:34").RowHeight = 0

If Intersect(Target, Range("H41")) Is Nothing Then Exit Sub
If Target.Value = "3" Then Sheets("Fotos").Rows("35:50").RowHeight = 14.25
If Target.Value <> "3" Then Sheets("Fotos").Rows("35:50").RowHeight = 0

If Intersect(Target, Range("I41")) Is Nothing Then Exit Sub
If Target.Value = "4" Then Sheets("Fotos").Rows("51:66").RowHeight = 14.25
If Target.Value <> "4" Then Sheets("Fotos").Rows("51:66").RowHeight = 0

If Intersect(Target, Range("J41")) Is Nothing Then Exit Sub
If Target.Value = "5" Then Sheets("Fotos").Rows("67:82").RowHeight = 14.25
If Target.Value <> "5" Then Sheets("Fotos").Rows("67:82").RowHeight = 0

If Intersect(Target, Range("K41")) Is Nothing Then Exit Sub
If Target.Value = "6" Then Sheets("Fotos").Rows("83:98").RowHeight = 14.25
If Target.Value <> "6" Then Sheets("Fotos").Rows("83:98").RowHeight = 0

If Intersect(Target, Range("L41")) Is Nothing Then Exit Sub
If Target.Value = "7" Then Sheets("Fotos").Rows("99:114").RowHeight = 14.25
If Target.Value <> "7" Then Sheets("Fotos").Rows("99:114").RowHeight = 0

If Intersect(Target, Range("M41")) Is Nothing Then Exit Sub
If Target.Value = "8" Then Sheets("Fotos").Rows("115:130").RowHeight = 14.25
If Target.Value <> "8" Then Sheets("Fotos").Rows("115:130").RowHeight = 0

If Intersect(Target, Range("N41")) Is Nothing Then Exit Sub
If Target.Value = "9" Then Sheets("Fotos").Rows("131:146").RowHeight = 14.25
If Target.Value <> "9" Then Sheets("Fotos").Rows("131:146").RowHeight = 0

If Intersect(Target, Range("O41")) Is Nothing Then Exit Sub
If Target.Value = "10" Then Sheets("Fotos").Rows("147:162").RowHeight = 14.25
If Target.Value <> "10" Then Sheets("Fotos").Rows("147:162").RowHeight = 0

If Intersect(Target, Range("P41")) Is Nothing Then Exit Sub
If Target.Value = "11" Then Sheets("Fotos").Rows("163:178").RowHeight = 14.25
If Target.Value <> "11" Then Sheets("Fotos").Rows("163:178").RowHeight = 0

If Intersect(Target, Range("Q41")) Is Nothing Then Exit Sub
If Target.Value = "12" Then Sheets("Fotos").Rows("179:194").RowHeight = 14.25
If Target.Value <> "12" Then Sheets("Fotos").Rows("179:194").RowHeight = 0

If Intersect(Target, Range("R41")) Is Nothing Then Exit Sub
If Target.Value = "13" Then Sheets("Fotos").Rows("195:210").RowHeight = 14.25
If Target.Value <> "13" Then Sheets("Fotos").Rows("195:210").RowHeight = 0

If Intersect(Target, Range("S41")) Is Nothing Then Exit Sub
If Target.Value = "14" Then Sheets("Fotos").Rows("211:226").RowHeight = 14.25
If Target.Value <> "14" Then Sheets("Fotos").Rows("211:226").RowHeight = 0

If Intersect(Target, Range("T41")) Is Nothing Then Exit Sub
If Target.Value = "15" Then Sheets("Fotos").Rows("227:242").RowHeight = 14.25
If Target.Value <> "15" Then Sheets("Fotos").Rows("227:242").RowHeight = 0

If Intersect(Target, Range("G41")) Is Nothing Then Exit Sub
If Target.Value = "2" Then Sheets("Eftersynsdata").Rows("22:27").RowHeight = 14.25
If Target.Value <> "2" Then Sheets("Eftersynsdata").Rows("22:27").RowHeight = 0

End Sub

-------------
Mvh. PI / Excel 2010

Besked fra: excelent
Posteringsdato: 26.Jan.2012 kl. 00:07

prøv:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("G41:T41")) Is Nothing Then Exit Sub
t_val = Target.Value: t_col = Target.Column

If t_col = 7 And t_val = "2" Then Sheets("Eftersynsdata").Rows("22:27").RowHeight = 14.25
If t_col = 7 And t_val <> "2" Then Sheets("Eftersynsdata").Rows("22:27").RowHeight = 0
If t_col = 7 And t_val = "2" Then Sheets("Fotos").Rows("19:34").RowHeight = 14.25
If t_col = 7 And t_val <> "2" Then Sheets("Fotos").Rows("19:34").RowHeight = 0

If t_col = 8 And t_val = "3" Then Sheets("Fotos").Rows("35:50").RowHeight = 14.25
If t_col = 8 And t_val <> "3" Then Sheets("Fotos").Rows("35:50").RowHeight = 0

If t_col = 9 And t_val = "4" Then Sheets("Fotos").Rows("51:66").RowHeight = 14.25
If t_col = 9 And t_val <> "4" Then Sheets("Fotos").Rows("51:66").RowHeight = 0

If t_col = 10 And t_val = "5" Then Sheets("Fotos").Rows("67:82").RowHeight = 14.25
If t_col = 10 And t_val <> "5" Then Sheets("Fotos").Rows("67:82").RowHeight = 0

If t_col = 11 And t_val = "6" Then Sheets("Fotos").Rows("83:98").RowHeight = 14.25
If t_col = 11 And t_val <> "6" Then Sheets("Fotos").Rows("83:98").RowHeight = 0

If t_col = 12 And t_val = "7" Then Sheets("Fotos").Rows("99:114").RowHeight = 14.25
If t_col = 12 And t_val <> "7" Then Sheets("Fotos").Rows("99:114").RowHeight = 0

If t_col = 13 And t_val = "8" Then Sheets("Fotos").Rows("115:130").RowHeight = 14.25
If t_col = 13 And t_val <> "8" Then Sheets("Fotos").Rows("115:130").RowHeight = 0

If t_col = 14 And t_val = "9" Then Sheets("Fotos").Rows("131:146").RowHeight = 14.25
If t_col = 14 And t_val <> "9" Then Sheets("Fotos").Rows("131:146").RowHeight = 0

If t_col = 15 And t_val = "10" Then Sheets("Fotos").Rows("147:162").RowHeight = 14.25
If t_col = 15 And t_val <> "10" Then Sheets("Fotos").Rows("147:162").RowHeight = 0

If t_col = 16 And t_val = "11" Then Sheets("Fotos").Rows("163:178").RowHeight = 14.25
If t_col = 16 And t_val <> "11" Then Sheets("Fotos").Rows("163:178").RowHeight = 0

If t_col = 17 And t_val = "12" Then Sheets("Fotos").Rows("179:194").RowHeight = 14.25
If t_col = 17 And t_val <> "12" Then Sheets("Fotos").Rows("179:194").RowHeight = 0

If t_col = 18 And t_val = "13" Then Sheets("Fotos").Rows("195:210").RowHeight = 14.25
If t_col = 18 And t_val <> "13" Then Sheets("Fotos").Rows("195:210").RowHeight = 0

If t_col = 19 And t_val = "14" Then Sheets("Fotos").Rows("211:226").RowHeight = 14.25
If t_col = 19 And t_val <> "14" Then Sheets("Fotos").Rows("211:226").RowHeight = 0

If t_col = 20 And t_val = "15" Then Sheets("Fotos").Rows("227:242").RowHeight = 14.25
If t_col = 20 And t_val <> "15" Then Sheets("Fotos").Rows("227:242").RowHeight = 0

End Sub

Besked fra: PI
Posteringsdato: 26.Jan.2012 kl. 22:33

Hej Excelent!

Mange tak for koden. Jeg har nu udbygget den fuldt ud, og den fungerer PERFEKT! Mange tak.

Er du også skarp til Matrixformler?

Jeg har i det vedhæftede regneark, fra oven og ned, anført:

- tabel for en forespørgsel

- mellemregningstabel med matrixformel

- inddatatabel

- liste med postnumre og tilhørende by

Kan du hjælpe med de matrixformler jeg skal have indtastet i cellerne i mellemregningstabellen (celle B8:M12)?

uploads/210/Excel-Matrix-PostPersoner_20120123.xls" rel="nofollow - uploads/210/Excel-Matrix-PostPersoner_20120123.xls

-------------
Mvh. PI / Excel 2010

Besked fra: excelent
Posteringsdato: 26.Jan.2012 kl. 23:00

http://pmexcelent.dk/matrix.xls

Besked fra: PI
Posteringsdato: 26.Jan.2012 kl. 23:15

Hej Excelent!

Mange tak for dit forslag. Jeg arbejder videre med det.

Dit pseudonym giver virkelig mening.

-------------
Mvh. PI / Excel 2010