Vise udvalgte data fra en række faneark på et separat faneark

Kræver nok lidt flere detailler, når du skriver:
"Alle data tastes ind i samme celler på hver fane, men de er ikke organiseret i deciderede rækker/kolonner"
"Jeg vil gerne have at udvalgte celler fra hver ugentlig status bliver lagret på en separat fane"

Hvis muligt er du velkommen til at sende filen/skitse af det ønskede til:
pb@supertekst-it.dk

Ideen er at det kun er uddrag af de data jeg har på de enkelte 'ugentlige status' faneark der skal vises på 'historisk status' fanearket.

Lige nu har jeg lavet en tabel i 'his. status' hvor jeg hver uge kopierer en ny række ind (trykker tab på sidste celle i nederste række) og derefter manuelt ændrer samtlige cellereferencer i den nye række til det faneark med den nyeste ugentlige status. - Det er dette jeg gerne vil have 'automatiseret' således at når jeg har tastet en ugentlig status ind på et 'ugentlig status' faneark så bliver (udvalgte) data vist på his.status fanearket.

Hvis man så derudover kan gøre således at jeg har et 'indtastningsark' der 'renses' når jeg har brugt det - og der gemmes et faneark med hver ugentlig status - så vil det lette arbejdet endnu mere. (Pt. opretter jeg et nyt faneark og kopierer forrige uges data ind på det og retter dataene.)

Forslag er afsendt til test.. - publiceres herefter.

Dim indtastArk
Dim arkDato
Public Sub Opdater()
    arkDato = Cells(1, 2)
   
    OpretDatoArk
'    nulStilIndtastning
    overførTilStatus
End Sub
Private Sub OpretDatoArk()
    Sheets("Indtastning").Activate
    With ActiveSheet
        .Cells.Select
        Selection.Copy
    End With
   
    ActiveWorkbook.Sheets.Add Before:=Sheets(3)
    Sheets(3).Name = arkDato
   
    Sheets(3).Activate
    ActiveSheet.Cells(1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
     
    Application.CutCopyMode = False
   
Rem ændring af farve for indtastningsfelter
    For Each cc In ActiveSheet.Range("A3:G26").Cells
        If cc.Interior.ColorIndex = 6 Then
            cc.Interior.ColorIndex = 20
        End If
    Next cc
   
    ActiveSheet.Cells(1, 1).Select
End Sub
Private Sub nulStilIndtastning()
    Set indtastArk = ActiveWorkbook.Sheets("Indtastning")
   
    For Each cc In indtastArk.Range("A3:G29").Cells
        If cc.Interior.ColorIndex = 6 Then
            cc.ClearContents
        End If
    Next cc
End Sub
Private Sub CommandButton1_Click()
    Opdater
End Sub
Private Sub overførTilStatus()
Dim næsteRæk, statusArk, aktuelleArk
    Set statusArk = ThisWorkbook.Sheets(1)
    Set aktuelleArk = ThisWorkbook.Sheets(3)
   
Rem Find første ledeige række
    With statusArk
        For ræk = 3 To 65000
            If .Cells(ræk, 1) = "" Then
                næsteRæk = ræk
                Exit For
            End If
        Next ræk
       
        .Cells(næsteRæk, 1) = arkDato                      'A - kol
        .Cells(næsteRæk, 2) = aktuelleArk.Range("D3")      'B
        .Cells(næsteRæk, 3) = aktuelleArk.Range("D4")      'C
        .Cells(næsteRæk, 4) = aktuelleArk.Range("E4")      'D
        .Cells(næsteRæk, 5) = aktuelleArk.Range("B12")      'E
        .Cells(næsteRæk, 6) = aktuelleArk.Range("B15")      'F
        .Cells(næsteRæk, 7) = CStr(aktuelleArk.Range("D18")) & _
            "/" & CStr(aktuelleArk.Range("B18"))            'G
        .Cells(næsteRæk, 8) = aktuelleArk.Range("B21")      'H
        .Cells(næsteRæk, 9) = aktuelleArk.Range("C21")      'I
        .Cells(næsteRæk, 10) = aktuelleArk.Range("C24")    'J
        .Cells(næsteRæk, 11) = CStr(aktuelleArk.Range("C27")) & _
            "/" & CStr(aktuelleArk.Range("B27"))                  'K
    End With
End Sub

Måske skulle vi "afregne" dette spørgsmål?

ja selvfølgelig, havde forsøgt at acceptere tidligere, men fandt først nu ud af at jeg skulle markere 'supertekst'før den ville acceptere..

Ok & tak