Avatar billede denero Juniormester
18. marts 2012 - 08:27 Der er 23 kommentarer og
1 løsning

Gentage makro i regneark

Bruger flg. kode til at flytte linjer fra ark1 til ark2, hvis der forekommer et "x" i kolonne l på ark1. Hvordan får jeg makroen til at køre hele kol "L" igennem indtil alle rækker er "afsøgt"?


    Sheets("1").Select
    Columns("L:L").Select
    Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Select
   
    Selection.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("A10000").Select
    Selection.End(xlUp).Select
    Selection.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
Avatar billede Ialocin Novice
18. marts 2012 - 12:19 #1
Hej Denero

Prøv om følgende vil virke for dig ??


Sub LøbNedGennemKolonneL
Dim rCell As Range
Dim r As Integer

'sæt r = sidste række i kolonne L indeholdende data
r = Sheets("1").Range("L65536").End(xlUp).Row

'for hver celle i kolonne L fra række 1 til sidste række med data
For Each rCell In Sheets("Sheet1").Range("L1:L" & r)

'vælg den aktuelle celle
rCell.select
   
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Select
   
    Selection.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("A10000").Select
    Selection.End(xlUp).Select
    Selection.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select


Next


End Sub




Med venlig hilsen, Nicolai
Avatar billede Ialocin Novice
18. marts 2012 - 12:21 #2
Hej Igen

Sættenissen er tidlig på spil i år :o)
Prøv lige denne her ...


Sub LøbNedGennemKolonneL
Dim rCell As Range
Dim r As Integer

'sæt r = sidste række i kolonne L indeholdende data
r = Sheets("1").Range("L65536").End(xlUp).Row

'for hver celle i kolonne L fra række 1 til sidste række med data
For Each rCell In Sheets("1").Range("L1:L" & r)

'vælg den aktuelle celle
rCell.select
   
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Select
   
    Selection.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("A10000").Select
    Selection.End(xlUp).Select
    Selection.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select


Next


End Sub


Med venlig hilsen, Nicolai
Avatar billede store-morten Ekspert
18. marts 2012 - 12:39 #3
Prøv at teste denne, indsat i et modul:
Sub test()
Application.ScreenUpdating = False

For Each c In Range("L1:L100").Cells
        If c.Value = "x" Then
            c.EntireRow.Select
            Selection.Cut
            Sheets(2).Select
            Range("L1").Select
            Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
            ActiveSheet.Paste
            Sheets(1).Select
        End If
    Next c

Application.ScreenUpdating = True
   
BeforeExit:
Application.ScreenUpdating = True

Exit Sub
'Her havner vi ved programfejl
ErrorHandle:
Resume BeforeExit 'Dirigerer tilbage til BeforeExit
End Sub
Avatar billede Thorp Praktikant
18. marts 2012 - 19:20 #4
Til store-morten,

bliver ErrorHandle: i din kode eksekveret automatisk ved fejl, eller kræver den en On Error GoTo ErroHandle først?
Avatar billede store-morten Ekspert
18. marts 2012 - 22:44 #5
Nej, der mangler en linie...

Sub test()

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

For Each c In Range("L1:L100").Cells
        If c.Value = "x" Then
            c.EntireRow.Select
            Selection.Cut
            Sheets(2).Select
            Range("L1").Select
            Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
            ActiveSheet.Paste
            Sheets(1).Select
        End If
    Next c

Application.ScreenUpdating = True
   
BeforeExit:
Application.ScreenUpdating = True

Exit Sub
'Her havner vi ved programfejl
ErrorHandle:
Resume BeforeExit 'Dirigerer tilbage til BeforeExit
End Sub


Godt set, Thorp.
Avatar billede denero Juniormester
19. marts 2012 - 11:40 #6
Hej Nicolai

Dit forslag genererer flg fejl.:
Run time error 91

Objekt variable or with block variable not set.
Avatar billede denero Juniormester
19. marts 2012 - 13:06 #7
Hej Store Morten

Har prøvet dit forslag af, men det når kun til at markere "første forekomst af "x" med tilhørende linje.
Avatar billede Thorp Praktikant
19. marts 2012 - 13:47 #8
Jeg har koblet store-mortens og lalocins forslag med en for i next loop i stedet for en for each loop. Det er vigtigt at der også er data i kolonne A i sheet 2, da denne bestemmer hvor linje indsættes.

Sub testTHIS()

Dim MyRange As Range
Dim r As Integer, i As Integer

On Error GoTo ErrorHandler

r = Sheets("1").Range("L65536").End(xlUp).Row

Sheets("1").Select
    Set MyRange = Columns("L:L")
   
    n = 1
    For i = 1 To r
   
    MyRange.Select
   
    Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Select
   
    Selection.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Sheets("2").Range("A10000").Select
    Selection.End(xlUp).Select
    Selection.Offset(1, 0).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
   
    Next

Beforeexit:

Exit Sub

ErrorHandler:

Resume Beforeexit

End Sub
Avatar billede store-morten Ekspert
19. marts 2012 - 15:36 #9
Prøv denne:
Jeg brugte: "Sheets(2).Select" i stedet for "Sheets("2").Select"
Men det kræver at det vittelig er Ark2 der er døbt "2"

Minus: sletter ikke rækker på Ark1
Sub test2()
On Error GoTo ErrorHandle

Application.ScreenUpdating = False

  For Each c In Range("L1:L100").Cells
        If c.Value = "x" Then
            c.EntireRow.Select
            Selection.Cut
            Sheets("2").Select
            Range("L1").Select
            Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
            ActiveSheet.Paste
            Sheets("1").Select
        End If
    Next c

Application.ScreenUpdating = True
   
Beforeexit:
Application.ScreenUpdating = True

Exit Sub
'Her havner vi ved programfejl
ErrorHandle:
Resume Beforeexit 'Dirigerer tilbage til BeforeExit
End Sub
Avatar billede store-morten Ekspert
19. marts 2012 - 21:58 #10
Sub Flyt_1til2()
Dim Start As Integer, i As Integer

Application.ScreenUpdating = False

Sheets("1").Select
Start = Range("L65536").End(xlUp).Row
   
    For i = 1 To Start

Set c = Range("L" & i)
If c.Value = "x" Then
    c.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("L1").Select
    Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
End If
    Next
   
Sheets("1").Range("L" & i).Select
Application.ScreenUpdating = True

End Sub
Avatar billede denero Juniormester
20. marts 2012 - 12:56 #11
Hej Morten

Den sidste du sendte virker, men den tager ikke alle forekomster(linjer) af "x" med.
Fint med at lade kol l bestemme indsætningspunkt for flyttede data, da der jo altid vil være data i den række.
Avatar billede store-morten Ekspert
20. marts 2012 - 13:03 #12
Har du x og X ?
Avatar billede denero Juniormester
20. marts 2012 - 13:09 #13
Nej, det havde jeg i første omgang (kan man gøre noget ved det?).

Hvis jeg "kører" makroen flere gange, bliver alle forekomster flyttet. Der er ikke rigtig noget mønster i, hvor mange der bliver taget med ved hver kørsel.
Avatar billede Thorp Praktikant
20. marts 2012 - 13:20 #14
Hvis der er to x'er lige efter hinanden, så bliver den næste i rækken sprunget over, da række n+1 bliver række n og den aktive række slettes.

Selection.Delete Shift:=xlUp

kan evt. løses med en sekundær tæller.
Avatar billede denero Juniormester
20. marts 2012 - 13:28 #15
øh - det må du lige forklare eller hvad gør jeg. Jeg mener jeg prøvede, at stille alle efter hinanden og der tog den heller ikke alle med? Ikke helt sikker.
Avatar billede Thorp Praktikant
20. marts 2012 - 13:36 #16
Store-Morten anvender en "For i=1 to Start .....Next løkke, til at gennemløbe rækkerne i kolonne L.

Hvis eksempelvis i =10 så tjekker koden værdien af L10 og hvis det er et "x" så flyttes rækken til det andet ark og linjen slettes. Men hermed bliver række 11 jo til række 10. Når koden når til Next så tæller i op til 11 og værdien i L11 tjekkes, men hvis den tidligere række 11 indeholdt et "x" så bliver den jo ikke tjekket, da den nu er række 10 og dermed springes der over.
Avatar billede store-morten Ekspert
20. marts 2012 - 17:40 #17
Prøv:
Sub Flyt_1til2()
Dim Start As Integer, i As Integer

Application.ScreenUpdating = False

On Error GoTo ErrorHandler

Sheets("1").Select
Start = Range("L65536").End(xlUp).Row
   
    For i = Start To 1 Step -1

Set c = Range("L" & i)
If c.Value = "x" Then
    c.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("L1").Select
    Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
  ElseIf c.Value = "X" Then
    c.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("L1").Select
    Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
   
End If
    Next
   
Application.ScreenUpdating = True

Beforeexit:
Application.ScreenUpdating = True
Set c = Nothing
Exit Sub

ErrorHandler:
Resume Beforeexit

End Sub
Avatar billede store-morten Ekspert
20. marts 2012 - 18:02 #18
Eller lidt kortere ( + Kommentar):
Sub Flyt_1til2()
Dim Start As Integer, i As Integer
'Skærmopdatering fra
Application.ScreenUpdating = False
'Ved fejl gå til
On Error GoTo ErrorHandler

Sheets("1").Select
'Find sidste udfyldte celle i kolonne L
Start = Range("L65536").End(xlUp).Row
   
    'Kør løkken fra sidste udfyldte celle i kolonne L til række 1
    For i = Start To 1 Step -1

Set c = Range("L" & i)
If c.Value = "x" Or c.Value = "X" Then
    c.EntireRow.Select
    Selection.Cut
    Sheets("2").Select
    Range("L1").Select
    Cells(65000, ActiveCell.Column).End(xlUp).Offset(1, -11).Select
    ActiveSheet.Paste
    Sheets("1").Select
    Selection.Delete Shift:=xlUp
End If
    Next
'Skærmopdatering til
Application.ScreenUpdating = True

Beforeexit:
'Ved fejl sættes
'Skærmopdatering til
Application.ScreenUpdating = True
'C tømmes
Set c = Nothing
'Før Subben forlades
Exit Sub

ErrorHandler:
Resume Beforeexit

End Sub
Avatar billede denero Juniormester
21. marts 2012 - 08:36 #19
Det virker.

Nicolai, Store Morten og Torp er et stjerneeksempel på godt samarbejde, når man har brug for hjælp. Ligger i et svar alle 3.

Tak for hjælpen!
Avatar billede Thorp Praktikant
21. marts 2012 - 08:56 #20
svar
Avatar billede store-morten Ekspert
21. marts 2012 - 11:38 #21
Velbekomme
Avatar billede denero Juniormester
21. marts 2012 - 11:41 #22
Hej, hvad skete der lige der. Troede at jeg kunne give point til jer alle, har ikke med vilje afvist Stor Morten. Mangler svar fra Nicolai.
Avatar billede Ialocin Novice
22. marts 2012 - 12:26 #23
Hej Denero

Ingen sure miner herfra :o)
Godt du fik løst dit issue ...

Med venlig hilsen, Nicolai
Avatar billede denero Juniormester
23. marts 2012 - 08:19 #24
Hej Nicolai
Alligevel - tak for hjælpen.
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
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

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



Seneste spørgsmål Seneste aktivitet
I dag 06:10 Excel åbner fil i kæmpe format Af Aske i Excel
I går 22:00 Datafordeler Af Lsk i PHP
I går 12:37 Summere beløb pr. dato Af TTA i Excel
31/1022:44 Tilslutte chassic fans Af viking69 i PC
31/1020:28 LED lysstofrør Af ErikHg i Fri debat