Oversigtssheet der samler op på flere underliggende sheets

Kan du ikke gøre således

=Ark2!A1 (indsættes i ark1 A1) og så kopier den udefter og nedad

og herefter for ark3 osv.

Hej,

Tak for dit svar. Jeg tror, at det er for enkelt. Det skal ske automatisk, så jeg er fri for at kopiere fra gang til gang (det skal bruges dynamisk). Derudover skal jeg kunne slette en række i fx sheet 2, som så ligeledes automatisk fjernes fra sheet 1. Og der skal helst ikke efterlades tomme linier.

/Line Bo

Hej

en flink og god ekspert har tidligere lavet noget til mig, så jeg har redigeret lidt til jeres formål.... Tak @mowi

Hvad hedder dit sheet 1?
hved du hvordan du bruger sådan en kodning?

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Ark1").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not wks.Name = "Totalskema" Then
            wks.Activate
            Range("A2:D2").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Ark1").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks
   
    Application.ScreenUpdating = True
End Sub

Hej sleeper,

Mange tak for dit svar. Mit oversigstark ligger i sheet 2 og hedder "Alle opgaver".
Jeg ved godt hvordan man bruger sådan en kodning - nogenlunde :-)

Hvad betyder WKS?
Er der ellers andre ting der er nødvendigt at ændre?

På forhånd tak
/Line Bo

Hej

WKS er en forkortelse af Worksheet

Alle steder hvor jeg har brugt sheetname "Ark1" skal du ændre til "Alle opgaver"

Så er der
Range("A2:D2").Select
Den skal ændres til hvor du ønsker at starte kopieringen i dine undersheets

Hej Sleeper,

Jeg har ændret "Ark1" til "Alle opgaver"

Og jeg har justeret "Range" feltet til der hvor jeg ønsker at starte kopieringen.

Herefter har jeg sat det ind i "this workbook" i VB. Det resulterer i, at den medtager sheet 1 og sheet 8. Den skal ikke medtage sheet 1 og den skulle gerne medtage sheetsene fra og med 2 til og med 8.

Har du nogen idé til hvad jeg gør galt? 

/Line

Argh, jeg havde glemt denne

If Not wks.Name = "Totalskema" Then

Skal rettes til

If Not wks.Name = "Alle opgaver" Then

Hej Sleeper,

Tak for din fortsatte tålmodighed! Det virker desværre stadig ikke. Første sheet ligger sig stadig ind over og sidste sheet medtages uden de mellemliggende sheets. Jeg har vedhæftet makroen som den ser ud nu forneden - måske du kan se nogle fejl??

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Alle opgaver").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not wks.Name = "Alle opgaver" Then
            wks.Activate
            Range("A2:J100").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Alle opgaver").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks
   
    Application.ScreenUpdating = True
End Sub

Hej Prøv denne
husk at rette "Dit Sheet 1 name"

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Alle opgaver").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not wks.Name = "Dit Sheet 1 Name" And
          Not wks.Name = "Alle opgaver" Then
            wks.Activate
            Range("A2:J100").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Alle opgaver").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks
 
    Application.ScreenUpdating = True
End Sub

Hej

Det virker ikke, jeg har lige lavet en forespørgsel på hvordan koden udbygges.
Jeg vender tilbage hurtigst muligt

Hej

Så er den løst

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Alle opgaver").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not wks.Name = ("Alle opgaver" & "Dit Sheet 1 Name") Then
            wks.Activate
            Range("A2:J100").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Alle opgaver").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    Application.ScreenUpdating = True
End Sub

Håber at dette virker.
JEg er skam meget tålmodig, jeg er herinde fordi jeg kan li at hjælpe :-)

hej

denne skulle være bedre

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Alle opgaver").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not (wks.Name = ("Alle opgaver") Or wks.Name = ("Dit Sheet 1 Name")) Then
            wks.Activate
            Range("A2:J100").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Alle opgaver").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

    Application.ScreenUpdating = True
End Sub

Hej Sleeper,

Nu sætter den rigtigt ind på sheet 2. Men den medtager forkert sheet 1 og kun det sidste sheet nr 8 - dvs ingen mellemliggende! De sheets den skal medtage er fra sheet nr 3 til og med sheet nr 8 og alle mellemliggende.

/Line

vil du ikke sende den webmaster@voga.dk

Hej Line

Tak for fremsendelsen af dit ark, det er lettere når man kan se det.
Her er den endelige kode

i Range("A2:J100").Select har jeg rettet til Range("A2:J2").Select da den efterfølgende linie sørger for at hele arket bliver markeret

Håber at det virker nu.

//Sleeper

Sub CollectData()
    Dim wks As Worksheet, NextRow As Integer

    Application.ScreenUpdating = False
    Sheets("Alle opgaver").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    For Each wks In Worksheets
        If Not (wks.Name = ("Alle opgaver") Or wks.Name = ("Forklaring")) Then
            wks.Activate
            Range("A2:J2").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Worksheets("Alle opgaver").Activate
            NextRow = Range("A65536").End(xlUp).Row + 1
            Cells(NextRow, 1).Activate
            ActiveSheet.Paste
        End If
    Next wks

Hej Sleeper,

Jubiiiii!!! Nu virker den. Tusind tak for hjælpen!!!

Jeg vil gerne give dig nogle point, men er ikke helt sikker på hvordan det foregår?!

/Line

hej

når jeg har lagt et svar, kan du markere mit navn, og trykke acceptere svar

Godt at det virker.

//Sleeper