11. februar 2009 - 23:09Der er
9 kommentarer og 1 løsning
Loop i makro / find celler med en bestemt farve
Hej Eksperter..
Jeg har en kalender i Excel hvor jeg gerne vil have, at en makro søger på en bestemt farve som angiver om ens ferie er godkendt eller mangler at blive godkendt. Hvis farven er gul er det fordi at den mangler at blive godkendt. Min makro skal kunne tage alle de celler som er gule og kopier over i et nyt excel ark. Kan man bygge videre på nedenstående kode ??
For Each c In ActiveSheet.UsedRange.Cells If c.Interior.ColorIndex = 6 Then c.Select Selection.Copy Sheets("Ark2").Select ActiveSheet.Paste Application.CutCopyMode = False Sheets("Ark1").Select Exit Sub End If
Nej, planen med arket er, at den enkelte bruger går ind og markere de datoer de gerne vil have fri med gul og så kan chefen markere dem grøn hvis han vil godkende deres ferie. Makroen skulle så tage alle de markerede datoer i de enkelte ark og smide dem over i et samlet ark så man ikke behøver at kigge alle ark igennem men isteden kan køre makroen og så har man et overblik over hvilke ting der skal godkendes, giver det mening ?? (-:
Prøv dette: Sheets("Sheet2").Select Range("A1").Select Sheets("Sheet1").Select Range("B1").Select Do While Range("B" & Selection.Row) <> "" With Range("B" & Selection.Row) If .Interior.ColorIndex = 6 Then .Select .Copy Sheets("Sheet2").Select ActiveSheet.Paste Application.CutCopyMode = False Selection.Offset(1, 0).Select Sheets("Sheet1").Select End If End With Selection.Offset(1, 0).Select Loop
Sub tst() Set sh1 = Sheets("Ark1") ' hent fra Set sh2 = Sheets("Ark2") ' kopier til For Each c In sh1.Range(sh1.Range("A1"), ActiveCell.SpecialCells(xlLastCell)) rk = sh2.Cells(1000, 1).End(xlUp).Row + 1 If c.Interior.ColorIndex = 6 Then c.Copy sh2.Cells(rk, 1) End If Next End Sub
Bare lige for at være lidt grådig, hvis man har f.eks. 14 ark (en kalender pr. medarbejder) kan man så få makroen til at søge i næste ark når den ikke finder flere forekomster i det aktive ark og det hele så ender op med at de fundne data bliver kopieret ind i det sidste ark med start i kolonne A og så B mv. ??
Sub tst2() 'Ret Last til aktuel destinations navn i linie herunder !!! Set tilArk = Sheets("Last") ' kopier til Application.ScreenUpdating = False For sh = 1 To ThisWorkbook.Sheets.Count If Sheets(sh).Name <> tilArk.Name Then Sheets(sh).Select: kol = kol + 1 tilArk.Cells(1, kol) = Sheets(sh).Name Sheets(sh).Range(Sheets(sh).Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select For Each c In Selection rk = tilArk.Cells(1000, kol).End(xlUp).Row + 1 If c.Interior.ColorIndex = 6 Then c.Copy tilArk.Cells(rk, kol) End If Next End If Next Application.ScreenUpdating = True tilArk.Select 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.
