Avatar billede Fesser1910 Nybegynder
11. februar 2009 - 23:09 Der 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
Avatar billede Fesser1910 Nybegynder
12. februar 2009 - 16:54 #1
Jeg vil gerne give 150 point for et svar (-:
Avatar billede excelent Ekspert
12. februar 2009 - 17:35 #2
Er farverne lavet med Betinget format ?
Avatar billede Fesser1910 Nybegynder
12. februar 2009 - 21:59 #3
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 ?? (-:
Avatar billede sfsoeren Novice
13. februar 2009 - 09:49 #4
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
Avatar billede excelent Ekspert
13. februar 2009 - 15:10 #5
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
Avatar billede Fesser1910 Nybegynder
13. februar 2009 - 22:31 #6
Hey "Kasket Karl" SPOT on .....

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. ??

Hvordan kan jeg tildele dig mine point ??? (o:

Hygge
Avatar billede Fesser1910 Nybegynder
13. februar 2009 - 22:33 #7
Hej sfsoeren,

Tak for bidraget, men mine point går til kasket karl.

Hygge
Avatar billede excelent Ekspert
14. februar 2009 - 09:55 #8
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
Avatar billede Fesser1910 Nybegynder
15. februar 2009 - 11:50 #9
Mange tak for hjælpen, jeg kan ikke finde ud af hvordan jeg giver dig ekstra point... men det var en konge hjælp.
Avatar billede excelent Ekspert
15. februar 2009 - 11:56 #10
velbeom - det er ok
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester