Automatisk kopiering af celler i ugrupperet område. VBA

Jeg skal til møde resten af dagen, så det er ikke for at være uhøftlig hvis jeg ikke lige svarer på de forslag jeg håber at der kommer :-)

Jeg forstår ikke helt spørgsmålet, Mile.
Har du nogen rækker der ikke er med i en gruppe?
Man kan godt teste hvilket gruppeniveau en række har (1 er dem med plusserne, 2 er de skjulte) men en række der ikke er med i en gruppe har også niveau 1.

Der er tale om liste på ca. 20.000 rækker - disse rækker er grupperet, sådan ca. en 6-8 ad gangen. Hvis man så forstiller sig, at man har alle de der plusser ude i venstre side, og man klikker på ét af plusserne, hvorved man får udvidet en enkelt gruppe, så er ønsket at man vha. en makro automatisk kan kopiere cellerne A:D i de 6-8 rækker, og indsætte i nyt excel ark.

Det er jeg bange for ikke er muligt. Der er ikke tilknyttet nogen evnts / handlinger til det at udvide en gruppering.

Et forslag er at når man har udvidet på Plusset, kan man stille sig i første celle til højre for og højreklikke/dobbeltklikke på den og få kopieringen til at ske.

?

Det gør så vidt jeg ved ikke noget hvis man skal klikke bestemt sted, inden man aktiverer makroen ....

Denne kode indsættes i arkets eget kodemodul.
Den overfører alle rækker (kolonne A:D) tilhørende et + til et nyt regneark.



Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim rgCopy As Range
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim i As Long
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A:A")) Is Nothing And Len(Target.Value) > 0 Then
    Cancel = True
    i = 1
    Do Until Target.Offset(i, 0).Rows.OutlineLevel = 1 'Or Target.Offset(i, 0).Rows.Hidden = True
        i = i + 1
    Loop
    Set rgCopy = Range(Target, Target.Offset(i - 1, 3))
    Set wbNew = Workbooks.Add
    Set wsNew = wbNew.Worksheets(1)
    rgCopy.Copy wsNew.Range("A1")
End If
End Sub

Hej Bak

Umiddelbart ser det lovende ud, men jeg vil nu lige spørge ham om han mener det alvorligt med cellerne A:D, for det ser lidt underligt ud her. Jeg melder tilbage....

Hej Bak

Nå - det var cellerne D:S han vil have med over. Kan koden ændres til det ? På forhånd tak...

PS: et lille ønske mere - kan den indsættes uden formattering ?

(der ligger nemlig noget betinget formattering på det ark, der kopieres fra, og det hele bliver så grønt når det indsættes i ny fil :-)

Øh - der er ikke formler i, så en indsæt speciel - værdier - vil godt kunne anvendes her.

ok, denne tager højde for ændringerne. test den lige. den er lavet til dobbelklik, men det kan du sagtens selv ændre til rigthclick, hvis du ønsker det

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rgCopy      As Variant
Dim wbNew      As Workbook
Dim wsNew      As Worksheet
Dim i%

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("A:A")) Is Nothing And Len(Target.Value) > 0 Then
        Cancel = True
        Do Until Target.Offset(i% + 1, 0).Rows.OutlineLevel = 1 'Or Target.Offset(i, 0).Rows.Hidden = True
            i% = i% + 1
        Loop
        rgCopy = Range(Target.Offset(, 3), Target.Offset(i%, 19))
        Set wbNew = Workbooks.Add
        Set wsNew = wbNew.Worksheets(1)
        wsNew.Range(wsNew.Cells(1, 1), wsNew.Cells(UBound(rgCopy, 1), UBound(rgCopy, 2))) = rgCopy
    End If
   
End Sub

Det ser simpelthen ud til at virke perfekt....Jeg ser lige om ham der skal bruge det bliver ligeså imponeret :-)

Det er bare for godt - lægger du lige et svar så du kan få nogle velfortjente points ??

ok, godt det funker :-)

Tak for hjælpen....