Kopier rækker fra originalt ark til nyt ark

En projektmappe indeholder som udgangspunkt et enkelt ark, her kaldet Ark1. Dette ark indeholder adskillige tusinde rækker om forskellige emner. Hver emne fylder 50 rækker, og hvis fx femte række i arket, således indeholder information om et bestemt spørgsmål i det første emne, vil række 55 indeholde information om det samme spørgsmål om det næste emne og så fremdeles. Der er altså ALTID 50 rækker pr. emne. Hver række kan indeholde mange kolonner, alle med kolonneoverskrifter i række 1.

Der ønskes nu en mulighed for at vælge en bestemt række som udgangspunkt. Nu skal denne og de følgende rækker med samme information (udgangsrækken + 50...) kopieres til et nyt ark, med samme navn som indholdet af C-kolonnen i den udpegede række. Rækkenummeret, der skal være udgangspunkt for makroens arbejde, indtastes via ven inputbox.

Først undersøges om det ark, der skal bruges, allerede eksisterer. Gør det ikke det, vil det blive oprettet og blive navngivet med indholdet af C-kolonnen i den relevante række. Når arket oprettes vil første række fra det oprindelige ark (kolonneoverskrifterne) blive kopieret over som kolonneoverskrifter i det nye ark. Der efter kopieres den relevante række og alle andre rækker med samme information (udgangsrækken + 50 + 50+ 50... osv.).

Sub Kopier()
    Dim MyRow As Single
    Dim MySheet As String

    Dim Exi As Boolean

    Application.ScreenUpdating = False

'Indtast relevant rækkenummer
    MyRow = InputBox("Indtast første række, der skal kopieres")
    MySheet = Sheets("Ark1").Range("C" & MyRow).Value

' Test om der er et ark til disse rækker, ellers tilføj det og indsæt overskrifter
    For Each sh In Worksheets
        If sh.Name = MySheet Then Exi = True: Exit For
    Next
    If Exi <> True Then
        Sheets.Add.Name = MySheet
        Sheets("Ark1").Select
        Rows(1).Copy
        Sheets(MySheet).Activate
        Selection.Insert Shift:=xlDown
    End If

' Kopier rækker fra "Ark1" til det ark, som identificeres ved navnet i c-kolonnen for de relevante rækker

    Do Until MyRow > 10000
        Sheets("Ark1").Select
        Rows(MyRow).Copy
        Sheets(MySheet).Activate
        ActiveSheet.Range("A1000000").End(xlUp).Offset(1, 0).Insert Shift:=xlDown
        MyRow = MyRow + 50
    Loop

    Application.ScreenUpdating = True

End Sub

I eksemplet hedder arket med de originale data Ark1, og det skal ændres i koden, hvis det skal hedde noget andet. Makroen er udarbejdet til Excel 2007 og nyere og vil give "Subscript out of range" fejl i ældre udgaver. Dette kan løses ved at rette ActiveSheet.Range("A1000000").Select til et tal omkring 32.000. Makroen er baseret på at der aldrig er mere end 10.000 rækker originale data, men er der det, kan Do Until MyRow > 10000 ændres til et relevant større tal.

- Tilbage til makroer -
- Tilbage til Excel -