19. februar 2006 - 13:55Der er
15 kommentarer og 1 løsning
Makro til fjernelse af irrelevante rækker
Jeg har oprettet et spørgeskema i Excel, der vha. en masse HVIS()'er "tilpasser" sig brugerens svar. Hvis brugeren fx svarer nej til et overordnet spørgsmål, så bliver alle underspørgsmål irrelevante, og celleværdien bliver automatisk til "slet". Jeg har nu brug for en makro-knap, der klargør besvarelsen ved (bl.a.) at slette alle de rækker i et bestemt interval, der i kolonne B har værdien "slet". Jeg har selv prøvet at få det til at virke vha. nogle besvarelser her på eksperten.dk omkring sletning af tomme rækker, men mine talenter rækker pt. ikke helt til at få det til at virke (blot delvist :-).
1. Kopier kolonne A til D, rækkerne 72 til 152 på arket ”Skema” (hvor knappen befinder sig) og indsæt værdierne+talformat+FORMATERING af tekst+cellekanter (IKKE funktionerne) på arket ”Besvarelse” i række 1 til 81.
2. Gennemsøg arket ”Besvarelse” kolonne B, række 1-81 for alle celler = ”slet” og slet de rækker, der opfylder denne betingelse (grunden til, at jeg bruger værdien "slet" i stedet for blanke celler er, at der faktisk skal være nogle tomme rækker hist og her for at overskueliggøre besvarelsen).
3. Om muligt: kopier kolonne A til D, rækkerne 1 til 'sidste række' på arket Besvarelse til clipboard (så det er lige til at sætte ind i et word-domument).
Sub SletCopy() ' Genvejstast:Ctrl+m ' Application.ScreenUpdating = False Range("A72:D152").Select Selection.Copy Sheets("Besvarelse").Select Range("B1").Select ActiveSheet.Paste Application.CutCopyMode = False Sheets("Skema").Select Range("a72").Select Sheets("Besvarelse").Select Range("B1").Select Application.ScreenUpdating = True MsgBox ("Rækker med 'slet' slettes nu") Application.ScreenUpdating = False Dim c As Range For Each c In Range("b1:b81") v = c.Value If v = "slet" Then c.EntireRow.Delete End If Next Range("A72").Select Application.ScreenUpdating = True End Sub
Det eneste der for mig at se er "galt" med ovennævnte er, at det der pastes ind i "Besvarelse" er FUNKTIONER og ikke VÆRDIER, dvs. jeg får en hel side (dvs. "Besvarelse") med celler, hvori der står "#REFERENCE", fordi dét der er kopieret fra "Skema" er en række celler med HVIS()-funktioner i, som refererer til andre celler i "Skema".
Det bedste VILLE faktisk være at få FUNKTIONERNE pastet med over i "Besvarelse" sådan som den gør med dit script nu, men skal jeg så manuelt sidde at tilføje "Skema!" foran alle cellereferencer i "Skema", eller kan det gøres vha. en makro (evt. i forbindelse med kopieringen)?...
Kan man måske tilføje et par linjer øverst i koden, der sletter ALT indhold på "Besvarelse" (således at dette ark altid er blankt, før der pastes) inkl. cellefletninger (man kan nemlig ikke udføre makroen to gange i træk pga. nogle cellefletninger)?
prøv lige denne: skulle du have kopieret formater,rammer osv. med?
Sub SletCopy() ' Genvejstast:Ctrl+m ' Application.ScreenUpdating = False Sheets("Besvarelse").Select Range("a1:e200").Select: Selection.Clear Sheets("Skema").Select Range("A72:D152").Select Selection.Copy Sheets("Besvarelse").Select Range("B1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Skema").Select Range("a72").Select Sheets("Besvarelse").Select Range("B1").Select Application.ScreenUpdating = True MsgBox ("Rækker med 'slet' slettes nu") Application.ScreenUpdating = False Dim c As Range For Each c In Range("b1:b81") v = c.Value If v = "slet" Then c.EntireRow.Delete End If Next Range("A72").Select Application.ScreenUpdating = True End Sub
Sub SletCopy() ' Genvejstast:Ctrl+m ' Application.ScreenUpdating = False Sheets("Besvarelse").Select Range("a1:e200").Select: Selection.Clear Sheets("Skema").Select Range("A72:D152").Select Selection.Copy Sheets("Besvarelse").Select Range("B1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Sheets("Skema").Select Range("a72").Select Sheets("Besvarelse").Select Range("B1").Select Application.ScreenUpdating = True MsgBox ("Rækker med 'slet' slettes nu") Application.ScreenUpdating = False Dim c As Range For Each c In Range("b1:b81") v = c.Value If v = "slet" Then c.EntireRow.Delete End If Next Range("A72").Select Application.ScreenUpdating = True End Sub
Dit svar er mere end godtaget, så hvis du lige laver et formelt "svar", kan jeg tildele point :-)
Jeg erstattede:
Dim c As Range For Each c In Range("b1:b81") v = c.Value If v = "slet" Then c.EntireRow.Delete End If
med:
Dim rng As Range, cell As Range, del As Range Set rng = Intersect(Range("B:B"), ActiveSheet.UsedRange) For Each cell In rng If (cell.Value) = "slet" Then If del Is Nothing Then Set del = cell Else: Set del = Union(del, cell) End If End If Next cell On Error Resume Next del.EntireRow.Delete
da det øverste af en eller anden grund ikke slettede rækkerne. Det virker i hvert fald nu.
Kan du mon sige mig, hvordan jeg laver en "submitknap", der eksekverer scriptet? Det ville endvidere være smart, hvis den afsluttende "kopifunktion" kun kopierede ned til sidste række (og altså ikke kopiere A1:D81, hvor fx rækkerne fra 50 og opefter er tomme. Til orientering har kolonne B i sidste række altid værdien "Afsluttende bemærkninger", hvis det kan hjælpe? Mange tak for hjælpen!
Højreklik på værktøjslinien Vælg Formularer Klik på Knap i den lille formular menu Placer musen der hvor du vil have øverste venstre hjørne af knap og klik I vindue 'Tildel makro' vælger du din sub (SletCopy) Klik på knap og slet tekst, og skriv din Tilpas størrelse ved at trække i kanterne
koden ligges lige før End Sub, hvis tekst "Afsluttende bemærkninger" ikke findes, afsluttes subben. Der søges i B1:B200, ret efter behov --------------------------------------------------------------- adr = "": Range("B1").Activate For i = 1 To 200 ActiveCell.Offset(1, 0).Activate If ActiveCell.Value = "Afsluttende bemærkninger" Then adr = ActiveCell.Address Next On Error GoTo ud Range("" & adr).Select ActiveCell.Offset(0, 2).Activate Range("a1:" & ActiveCell.Address).Select Selection.Copy ud:
nå ok jeg kan se at bak netop har besvaret dette spørgsmål og hans løsning er bestemt mere elegant end min (som sædvanlig) men man kan da sige du får mere for pengene her lol :-)
Jeg synes bestemt, at jeg har fået meget for pengene her, ja! :-)
Mange tak for hjælpen!!
Synes godt om
Ny brugerNybegynder
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.
