Tæl rækker, kopier og indsæt samme antal rækker i nyt ark

Prøv med denne - det virker, men spørgsmålet om det er præcis det du efterspørger...

Sub KopierRækker()
\' Makro indspillet 14-01-2002 af Martin Moth-Lund
 
  Dim i, Rækker, StartRække As Integer
  Application.ScreenUpdating = False \'Så slipper du for at se skærmen flimre mens den skifter mellem de 2 ark
  StartRække = 1 \'Forudsætter, at du starter i række et i dit \"kilde-ark\"
  Rækker = StartRække
  Do While ActiveSheet.Cells(Rækker, 1).Value <> 0
    ActiveSheet.Rows(Rækker).Select
    Selection.Copy
    Sheets(\"Ark2\").Select \'Vær opmærksom på hvilket navn arket har - jeg har kaldt det Ark2
    Rows(Rækker).Select
    Selection.Insert Shift:=xlDown
    Sheets(\"Ark1\").Select \'Vær opmærksom på hvilket navn arket har - jeg har kaldt det Ark1
    Rækker = Rækker + 1
  Loop
  Sheets(\"Ark1\").Select
  ActiveSheet.Range(\"a1\").Select
  Application.ScreenUpdating = True \'Er ikke klar om denne linie er nødvendig - men den skader ikke ;-)
  MsgBox \"Der er kopieret \" & Rækker & \" rækker fra Ark1 til Ark2\"
End Sub

Øh-bøø - jeg bruger ikke variablen StartRække til noget fornuftigt. Skift de første 4 linier ud med

  Dim i, Rækker As Integer
  Application.ScreenUpdating = False \'Så slipper du for at se skærmen flimre mens den skifter mellem de 2 ark
  Rækker = 1

Du skal starte nedenstående makro, når du står i det dataområde der skal kopires:
Sub kopierdata()
Set rngA = Selection.CurrentRegion
x = rngA.Rows.Count
Set rngny = Application.InputBox(\"kopieres til ??\", , , , , , , 8)
With rngny
    .Worksheet.Select
    Rows(.Row & \":\" & .Row + x - 1).Insert Shift:=xlDown
    rngA.Copy
    .Offset(-x, 0).Select
    ActiveSheet.Paste
End With
End Sub

->Martin - din macro fungerer ikke helt som ønsket - den kopierer kun første række - det ser ikke ud til at den checker hele A-kolonnen - men det er ret tæt på.
-> Bak - en spændende løsning - måske lidt over min fatteevne ;-) - hvad er \"kopieres til ?\" et eksisterende ark? en eksisterende projektmappe ? eller ? fungerer den iøvrigt over flere ark ?

Herlige inspirerende inputs - men jeg er ikke i mål endnu.
/Flemming

makroen er lavet så den vælger hele det område din aktive celle befinder sig i når du starter den. Derefter kommer inputboxen (kopieres til) og du kan nu vælger hvilket ark og celle du vil smide kopien ind i.
På det valgte sted indsættes så x antal linier og kopien indsættes.

->bak - så er den registreret på lystavlen - det er en mulighed, men kræver lidt forædling - sover lige på den!
/F

Hvis \"min\" macro kun kopierer første række, er det fordi at enten 2. række er tom, eller kolonne A er tom

Den starter jo i række 1, og kopierer de nedenstående rækker indtil den møder en tom række (tjekker på første kolonne i hver række). Det kan jo sagtens laves om til at enten tjekke en anden kolonne eller samtlige kolonner (vha. en ekstra løkke).

Det virker hos mig, jeg kan da godt sende arket...

/Martin

Prøv med denne version 0.01 (tidligere 0.00)
Den tjekker de første 20 kolonner - er der data i en af dem, kopieres rækken, ellers ikke.

Sub KopierRækker()
  Dim i, Kolonne, Rækker As Integer
  Application.ScreenUpdating = False
  Rækker = 1
  Kolonne = 1
  For Kolonne = 1 To 20
    Do While ActiveSheet.Cells(Rækker, Kolonne).Value <> 0
      ActiveSheet.Rows(Rækker).Select
      Selection.Copy
      Sheets(\"Ark2\").Select
      Rows(Rækker).Select
      Selection.Insert Shift:=xlDown
      Sheets(\"Ark1\").Select
      Rækker = Rækker + 1
    Loop
  Next Kolonne
  Sheets(\"Ark1\").Select
  ActiveSheet.Range(\"a1\").Select
  Application.ScreenUpdating = True
  MsgBox \"Der er kopieret \" & Rækker - 1 & \" rækker fra Ark1 til Ark2\"
End Sub

/Martin

Ups. En lille fejl - version 0.02 kommer snarest!

Version 0.02. Kopierer rækker fra nr. 1 til den række, hvor der ikke er data i de første 20 kolonner. Kopierer fra Ark1 til Ark2... Skift selv arknavne ud (eller hent dem med en inputboxe), og vælg selv om løkken skal køre mere eller mindre end 20 kolonner igennem. Startrække kunne også hentes med en inputbox...

Sub KopierRækker()
  Dim i, Kolonne, Rækker As Integer
  Application.ScreenUpdating = False
  Rækker = 1
  Kolonne = 1
  Do While 1 = 1 \'Dvs. altid
    If ActiveSheet.Cells(Rækker, Kolonne).Value = 0 Then
      Kolonne = Kolonne + 1
      If Kolonne = 20 Then GoTo Kopiering_slut
    Else
      ActiveSheet.Rows(Rækker).Select
      Selection.Copy
      Sheets(\"Ark2\").Select
      Rows(Rækker).Select
      Selection.Insert Shift:=xlDown
      Sheets(\"Ark1\").Select
      Rækker = Rækker + 1
      Kolonne = 1
    End If
  Loop
Kopiering_slut:
  Sheets(\"Ark1\").Select
  ActiveSheet.Range(\"a1\").Select
  Application.ScreenUpdating = True
  MsgBox \"Der er kopieret \" & Rækker - 1 & \" rækker fra Ark1 til Ark2\"
End Sub

Hej Martin
Jeg tror jeg næsten er med på hvor du vil hen - jeg har måske ikke været helt klar i mit spørgsmål - Jeg har et ark i en projektmappe - dette ark vedligeholdes løbende - der tilføjes rækker og nogle gange fjernes rækker.
mine kolleger skal, ved aktivering af en makro, åbne, kopiere fra kildeark - indsætte ark, indsætte data + samme rækkeantal som kopieret fra kildeark - kolonne antallet er aldrig over 6 - men det er kun rækkerne der er \"interessante\".
Du må iøvrigt gerne mail til mig - fln@ascom.dk.
/Flemming

Flemming> er der tomme rækker??

-> yes - der er en \"underopdeling\" af produkter, så hver undergruppe har en overskrift - denne overskrift vil jeg gerne have med.
/Flemming

Ok så prøv lige denne.

Sub kopierdata()
Set lastcell = Range(\"A65536\").End(xlUp) \'.Offset(0, 0)
Set rngA = Range(\"a1:f\" & lastcell.Row)
x = rngA.Rows.Count
Set rngny = Worksheets(\"Sheet2\").Range(\"A1\")
With rngny
    .Worksheet.Select
    Rows(.Row & \":\" & .Row + x - 1).Insert Shift:=xlDown
    rngA.Copy
    .Offset(-x, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End With
End Sub

Sorry, glem den, den kopierer også de tomme linier med over

Denne springer tomme linier over

Sub kopierdata()
b = 0
Set lastcell = Range(\"A65536\").End(xlUp) \'.Offset(0, 0)
Set rngA = Range(\"a1:\" & lastcell.Address)
x = rngA.Rows.Count
ReDim matrix(x, 6)
For a = 1 To x
    If IsEmpty(Cells(a, 1)) = False Then
        b = b + 1
        For y = 1 To 6
        matrix(b, y) = Cells(a, y)
        Next
    End If
Next
Set rngny = Worksheets(\"Sheet2\").Range(\"A1\")
With rngny
    .Worksheet.Select
    Rows(.Row & \":\" & .Row + b - 1).Insert Shift:=xlDown
    .Offset(-b, 0).Select
    For a = 1 To b
        For y = 1 To 6
            Cells(a, y) = matrix(a, y)
        Next
    Next
    End With
End Sub

->bak - spørgsmål - tester din makro \"kun\" i kolonne A ?

Ja

Tester på alle celler:

Sub kopierdata()
Set rngA = Range(\"A1:\" & Selection.SpecialCells(xlCellTypeLastCell).Address)
x = rngA.Rows.Count
ReDim matrix(x, 6)
b = 1
For a = 1 To x
  check = 0
  For y = 1 To 6
    If IsEmpty(Cells(a, y)) = False Then
      matrix(b, y) = Cells(a, y)
      check = 1
    End If
  Next
  b = b + check
Next
Worksheets(\"Sheet2\").Select
Rows(1 & \":\" & b - 1).Insert Shift:=xlDown
For a = 1 To b - 1
  For y = 1 To 6
      Cells(a, y) = matrix(a, y)
  Next
Next
End Sub

Jeg har afsat lidt flere points - og deler dem ligeligt mellem bak og martin - tak for hjælpen.
martin publicerer du din endelige løsning ?

Den endelige løsning er lig Version 0.02, se tidligere indlæg. En meget simpel løsning, som samtidig er overskuelig, logisk og nem at rette i (synes jeg da selv;-) Men bak's løsning er måske bedre...  /Martin