Makro og VBA - Betinget formattering flytter række til nyt ark

Betinget formattering flytter række til nyt ark

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=3671
Udskrevet den: 23.Nov.2024 kl. 09:59

Emne: Betinget formattering flytter række til nyt ark

Besked fra: tyndetove
Emne: Betinget formattering flytter række til nyt ark
Posteringsdato: 06.Nov.2018 kl. 10:46

Hej alle,

Jeg har brug for lidt hjælp til mit excel på arbejdet. I forvejen så har jeg pæn erfaring med både formler og VBA.

Jeg sidder og er igang med at lave et status dokument hvor jeg har lavet farve-betinget status (Rød, gul, grøn). Da det er et dynamisk ark, så skal de "grønne" gerne forsvinde så det kun er røde og gule på status-arket.

Hvordan kan jeg nemmest få en række til at forsvinde over i nærmeste ledige række i et nyt ark(sheet) når jeg vælger den grønne status? Jeg tænker der skal en form for VBA ind over her.

Alternative løsninger er også velkomne, men det skal bare være nemt at bruge for folk der ikke er excel-kyndige :)

På forhånd mange tak for hjælpen :)

Svar:

Besked fra: maxzpad
Posteringsdato: 07.Nov.2018 kl. 10:40

Jeg tænker, at det letteste er at skjule de grønne ved hjælp af et autofilter. Du har sandsynligvis en kolonne, hvis værdier betinger rød, gul og grøn, så hvis du filtrerer værdien for grøn væk, vil du have de to andre tilbage (og så behøver du ikke flytte rækker til et andet ark). Dette kan du så skrive en Sheet_Change-makro, der opdaterer automatisk i takt med ændringer.

Besked fra: tyndetove
Posteringsdato: 07.Nov.2018 kl. 12:44

Tak for svar.

Jeg endte med at tage en eksisterende løsning og tilrette den til mit ark, så det virker som det skal lige nu. Den mangler dog noget funktionalitet hvis den skal bygges videre på, men det virker da lige nu :)

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range

Dim lastRow As Integer, lastRowOut As Integer, pasteRow As Integer

Dim wsÅbne As Worksheet, wsLøst As Worksheet

Set wsÅbne = ThisWorkbook.Sheets("Aktuelt")

Set wsLøst = ThisWorkbook.Sheets("Godkendt")

lastRow = wsÅbne.Cells(wsÅbne.Rows.Count, 2).End(xlUp).Row

' The variable KeyCells contains the cells that will

' cause an alert when they are changed.

Set KeyCells = wsÅbne.Range("G2:G" & lastRow)

If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then

For i = 2 To lastRow

lastRowOut = wsLøst.Cells(wsLøst.Rows.Count, 2).End(xlUp).Row

If lastRowOut = 1 Then

pasteRow = 2

Else

pasteRow = wsLøst.Cells(wsLøst.Rows.Count, 2).End(xlUp).Row + 1

End If

If wsÅbne.Range("G" & i).Value = "GODKENDT" Then

wsÅbne.Range("A" & i & ":G" & i).Cut Destination:=wsLøst.Range("A" & pasteRow)

wsÅbne.Rows(i).EntireRow.Delete

End If

Next i

End If

End Sub