Makro til flytning af rækker afhængig af indhold i bestemte celle

Hvis dine tabeller er navngivne områder, som hedder Tabel1, Tabel2 o.s.v.

så virker denne makro.

den kopierer kun linien, hvis den skal klippes kan du selv ændre.

Sub FindFraTabel()
Dim F, T, U, A, NR As Integer, K As String
Application.ScreenUpdating = False
Application.CutCopyMode = False
Worksheets("Ark1").Activate
Range("b65536").Select
F = Selection.End(xlUp).Row ' Finder ud af hvor mange rækker der er med data på ark1
Range("a1").Select
For NR = 1 To 2 ' antal tabeller
  Worksheets("Ark" & NR + 1).Activate
  Range("B65536").Select
  U = Selection.End(xlUp).Row + 1 ' Finder ud af hvor mange rækker der er med data på ark2, ark3 o.s.v.
  Range("a1").Select
  For Each C In Range("Tabel" & NR) ' tabel1 o.s.v. er et navngivet område
    Alen = Len(C)
If Alen = 0 Then GoTo Slut
    For T = 1 To F
      Worksheets("Ark1").Select
      K = Left(Cells(T, 2), Alen)
    If K = Str(C) Or Val(K) = C Then
      Rows(T & ":" & T).Select
      Selection.Copy '  kopierer hele linien
      Sheets("Ark" & NR + 1).Select
      Rows(U & ":" & U).Select
      ActiveSheet.Paste
      U = U + 1
    End If
    Next T
Next C
Slut:
Next NR
Application.ScreenUpdating = True
Application.CutCopyMode = True
Sheets("Ark" & NR + 1).Select
Range("B" & U).Select

Jeg har lavet et eksempel her :  http://www.ah6.subnet.dk/Tabeller.xls

Måske du kan bruge det. Det kopierer, så du skal selv skifte ud med CUT i linje 26, hvis det er det du vil :-)

Det ser godt ud. Bruger lige lidt tid til at teste.

>>aheiss

Jeg er ved at teste din. Jeg kan desværre ikek få det til at virke med Cut i stedet for copy - jeg får fejl længere nede i makroen.

Jeg har retten den.  http://www.ah6.subnet.dk/Tabeller.xls

Har forsøgt med den nye - men jeg kan ikke få det til at funke. Makroen fejler når jeg bruger mine egne data (den laaaaaaaaange liste) Det sker ikke med det første ark du lagde ud.

OK - jeg kunne jo prøve med dine data : ah6@sol.dk

ok, Mailer et ark om 2 min.

ark tilbage om 2 min.

ark modtaget - Tester...

Så har jeg testet og rettet lidt til. Det virker perfekt.

Jeg har bare et lille problem - det tager 10-20 minutter at køre makroen. Er det muligt at slette efter hver tabel? Som det er nu skal hele listen (flere tusiende linier) checkes igennem med hvert enenste felt i alle tabellerne. Det bliver hurtigt til mere end 100.000 opslag - og det tager jo lidt tid...

Godt at funktionaliteten er på plads. Jeg kigger lige på optimeringsmuligheder i aften, men jeg mener da også at der helt klart ligger muligheder - specielt mht. sletning af rækker som du selv er inde på.

Jeg kan se jeg er kommet til at accepterere kabbaks svar - det var ikke meningen. Hvad gør man så?

ja, jeg kunne forstille mig at den slette rutine som du har lagt ind kunne køres efter hver tabel, eller noget i den retning. Jeg har selv prøvet at 'fuske' lidt med din kode for at slette oftere - men det ønskede resultat udebliver.

brilleabe --> jeg opretter et spørgsmål og så skriver du et svar, så får du points retur

her . http://www.eksperten.dk/spm/406946

Jeg har nu optimeret nogle procedurer m.m. I min test er den blevet 5 gange hurtigere, så du må se hvordan den kører for dig.
_______________________________________________________________
Sub klip()
Application.ScreenUpdating = False
Dim tabel As Range
Dim Liste As Range
Set Liste = Sheets("liste").Range("a:a")
For a = 1 To 10    '  a angiver tabel og dermed Sheet
Sheets("tabeller").Select
Set tabel = Range(Cells(1, a), Cells(60000, a))
    For b = 2 To 60000  ' b  angiver tabelrækken
Sheets("tabeller").Select
        tabel(b, 1).Select
        If Selection = "" Then
        GoTo fortsæt
        End If
        data = ActiveCell.Value
        langde = (Len(ActiveCell))
        For c = 1 To 60000    '  c angiver listerækken
            Sheets("liste").Activate
            Liste(c, 1).Select
            If Selection = "" Then
            GoTo fortsæt2
            End If
            If Left(Selection, langde) = Left(data, langde) Then
                Liste(c, 30) = 1
                Selection.EntireRow.Copy
                Sheets("Sheet" & a).Select
                Range("a60000").Select
                ActiveCell.End(xlUp).Offset(1, 0).Select
                ActiveSheet.PasteSpecial
            End If
            Sheets("liste").Activate
        Next
fortsæt2:
    Next
fortsæt:
Sheets("Liste").Select
Do
      Range("AD1").Select
      ActiveCell.End(xlDown).Select
      Selection.EntireRow.Delete
Loop Until Selection.Row = 65536
Next
Application.CutCopyMode = False
End Sub

Det er bare super. Hastigheden er øget betydeligt! Jeg opretter et nyt sp med point.


http://www.eksperten.dk/spm/407061

Her er lidt inspiration til en yderligere optimeret model. Skulle gerne være mange gange hurtigere, men jeg kender jo ikke rådata'ene, så der kan være lidt der skal ændres, men det klarer aheiss sikkert :-)
Som du ser, så undgår jeg bevidst alle selects og activate, da det sløver meget.

Sub klip()
Dim wsL As Worksheet
Dim wsT As Worksheet
Dim tabel As Range
Dim Listen As Range
Dim vTabeller As Variant
Dim vListe As Variant
Dim I As Long
Application.ScreenUpdating = False
Set wsL = Worksheets("Liste")
Set wsT = Worksheets("Tabeller")
'Hele kolonne B (celler med data) læses ind i vListe
vListe = wsL.Range(wsL.Cells(1, 2), wsL.Cells(65536, 2).End(xlUp))
'Alle tabellerne læses ind i vTabeller
vTabeller = wsT.Range("A1").CurrentRegion

'for hvert element i vListe (kol B) check mod Vtabel
For b = 1 To UBound(vListe, 1)
    'Hver "kolonne i tabeller
    For a = 1 To UBound(vTabeller, 2)
        'hver række i Tabeller
        For I = 1 To UBound(vTabeller, 1)
            If vTabeller(I, a) = "" Then GoTo fortsæt
            'Sammenlign
            If vListe(b, 1) Like vTabeller(I, a) & "*" Then
                'Kopier hele rækken
                wsL.Range("A" & b).EntireRow.Copy Worksheets("Ark" & a) _
                            .Range("a65536").End(xlUp).Offset(1, 0)
                'Rens den gamle
                wsL.Range("A" & b).EntireRow.ClearContents
            End If
        Next
fortsæt:
  Next
Next
End Sub

Ser godt ud bak. Det er kanon hurtigt - må lige prøve om jeg kan få det til at virke. (den springer over en del rækker).

>Bak,
Godt ord igen...
Jeg bruger kolonne a og ikke b, det var derfor den efterlod rækker hist og her...

Først tog det 20min - så tog det 10. Nu vare det ikke mere end 3 min!

Fantastisk.

Det skal lige nævnes at ud af de 3 min er det meste opdatering af 10 pivot-tabeller. (kan det gøres hurtigere?)

Flytningen/sorteringen af de mere end 4.500 rækker tager omkring 18 sekunder.

Disse Pivottabeller, er de baseret på data i de tre ark ?
Husk at hvis du har flere pivottabeller basret på samme dataområde, så skal du oprette den første og derefter basere de resterende på den. Så er der kun een pivotcache der skal opdateres.

BAK -> Det må jeg sige - rigtigt godt. Smart at læse tabeller ind på den måde. 5 gange hurtigere igen.

Brilleabe ->  Koden ser sådan ud nu, hvis du ikke allerede har lavet det. Der skulle jo ikke mange rettelser til. Springer den stadig rækker over ?

Sub klip()
Dim wsL As Worksheet
Dim wsT As Worksheet
Dim tabel As Range
Dim Listen As Range
Dim vTabeller As Variant
Dim vListe As Variant
Dim I As Long
Application.ScreenUpdating = False
Set wsL = Worksheets("Liste")
Set wsT = Worksheets("Tabeller")
vListe = wsL.Range(wsL.Cells(1, 1), wsL.Cells(65536, 1).End(xlUp))
vTabeller = wsT.Range("A1").CurrentRegion
For b = 1 To UBound(vListe, 1)
    For a = 1 To UBound(vTabeller, 2)
        For I = 1 To UBound(vTabeller, 1)
            If vTabeller(I, a) = "" Then GoTo fortsæt
            If vListe(b, 1) Like vTabeller(I, a) & "*" Then
                wsL.Range("A" & b).EntireRow.Copy Worksheets("Sheet" & a) _
                            .Range("a65536").End(xlUp).Offset(1, 0)
                wsL.Range("AA" & b) = 1
            End If
        Next
fortsæt:
  Next
Next
Do
      Range("AA1").Select
      ActiveCell.End(xlDown).Select
      Selection.EntireRow.Delete
Loop Until Selection.Row = 65536
End Sub

Skulle man lige spare en select i loopet :

Do
      Range("AA1").End(xlDown).Select
      Selection.EntireRow.Delete
Loop Until Selection.Row = 65536

Så er jeg lige kommmet hjem fra job....Jeg ser lige på sagerne i løbet af aftenen - så vender jeg tilbage.

Det ser sgu' godt ud. jeg giver 150 aheiss for det fine arbejde - og så 50 til bak for at pudse sagerne af. (lad mig vide hvis i ikke er enige i fordelingen.)



http://www.eksperten.dk/spm/408040