2 regneark der samles i et 3. med mulighed for tilføjelse af data

Formel eller makro?
Hvilken orden på ark1?

det er lidt underordnet om det er formel eller makro for mig.
der er allerede en oversigtslinje i begge ark som ikke behøver at komme med (hvert fald ikke 2 gange).

Jeg tænker orden er underordnet da man kan vælge at sortere efter produktnavn, Varenummer etc. efterfølgende.

Ok - er der mulighed for at du kunne uploade filen / en model - eller maile den. @-adresse under min profil.

Joo men jeg vil jo gerne selv gøre det der skal gøres så jeg har haft det i Hænderne

Hej kahl

Når du selv vil have fingrene i det, vil jeg foreslå, at du laver en makro, der først markerer dataområdet på ark2 og kopierer det til ark1; og derefter markerer dataområdet på ark3, og kopierer det til første tomme række under på ark 1.

Hvis du ikke bruge de øverste rækker på fanebladene kan du på hvert faneblad oprette en makroknap, der eksekverer den samme makro.

Prøv med denne makro, som ikke kopierer linie 1, der er overskrift på alle 3 ark:

Sub Kopier()
Dim CountArk2, CountArk3 As Integer
CountArk2 = Application.CountA(Sheets("Ark2").Columns(1))
CountArk3 = Application.CountA(Sheets("Ark3").Columns(1))
Sheets("Ark2").Rows("2:" & CountArk2).Copy Destination:=Sheets("Ark1").Cells(2, 1)
Sheets("Ark3").Rows("2:" & CountArk3).Copy Destination:=Sheets("Ark1").Cells(CountArk2 + 1, 1)
End Sub

Rem Version (005)_1
Option Explicit
Dim totalArkRæk As Integer, aktuelleArk As String, flagNyOpret As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ProtectMe "TJI"
    ProtectMe "Mekaniker Værkstedet"
End Sub

Private Sub Workbook_Open()
    Sheets("Tji total").Activate
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If (Sh.Name = "TJI" Or Sh.Name = "Mekaniker Værkstedet") Then  'fjern beskyttelse
        UnProtectMe Sh.Name
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim formel As String
    Application.ScreenUpdating = False

    If (Sh.Name = "TJI" Or Sh.Name = "Mekaniker Værkstedet") And InStr(Target.Address, ":") = 0 And _
        (ActiveSheet.Range("I" & Target.Row) = "" Or flagNyOpret = True) Then    'Ej ind i kode hvis markerig ikke er 1 celle eller Tidsreg.udfyldt
        If Target.Row > 1 Then
            If Target.Column < 9 Then
                UnProtectMe Sh.Name
                If Target.Value = "" Then
                    Target.Value = 0
                ElseIf Target.Value = 0 Then
                    Sh.Cells(Target.Row, 9).Value = ""
                Else
                    Sh.Cells(Target.Row, 9).Value = Now()
                    flagNyOpret = True
                End If
               
                If erCellerUdfyldt(Target.Row) = True Then
                    UnProtectMe Sh.Name
                    aktuelleArk = Sh.Name
                   
Rem - indsæt ny række i "bunden" af Total ark
                    indsætNyRække
                    Sheets(aktuelleArk).Activate
                   
                    Range("A" & Target.Row & ":H" & Target.Row).Copy
               
Rem Opdater Tji-Total
                    Sheets("Tji total").Activate
                   
                    ActiveSheet.Range("A" & totalArkRæk + 1).Select
                    ActiveSheet.Paste
                   
Rem Opbyg skema i totalark for indsatte række
                    afsætSkema totalArkRæk
                   
Rem Indsæt formel i kolonne C (Antal), der peger på "kildeark"
                    formel = "=" & "'" & aktuelleArk & "'!" & "C" & Target.Row
                    ActiveSheet.Range("C" & totalArkRæk + 1).Formula = formel
   
Rem Marker nyoprettelse som afsluttet
                    flagNyOpret = False
                   
Rem Vend tilbage til ajf. ark
                    Sheets(aktuelleArk).Activate
                    Application.CutCopyMode = False
                    ProtectMe Sh.Name
                End If
            End If
        End If
    End If
End Sub

Private Sub indsætNyRække()
    Sheets("Tji total").Activate
    totalArkRæk = Cells(Rows.Count, "A").End(xlUp).Row                          'ActiveCell.SpecialCells(xlLastCell).Row
    ActiveSheet.Rows(totalArkRæk + 1 & ":" & totalArkRæk + 1).Select
    Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Private Function erCellerUdfyldt(række)
Dim cc
    For Each cc In Range("A" & række & ":H" & række).Cells
        If IsEmpty(cc) = True Then
            If cc.Column <> 5 Then
                erCellerUdfyldt = False
                cc.Interior.ColorIndex = 3
                Exit Function
            End If
        Else
            cc.Interior.ColorIndex = xlNone
        End If
    Next cc
    erCellerUdfyldt = True
End Function

Private Sub afsætSkema(ræk)
    With ActiveSheet
        .Range("A" & ræk & ":H" & ræk).Select
        Selection.Copy
        .Range("A" & ræk + 1).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    End With
End Sub

Public Sub ProtectMe(ByRef sSheet As String)
    Sheets(sSheet).Protect Password:="TITest1234"
End Sub

Public Sub UnProtectMe(ByRef sSheet As String)
    Sheets(sSheet).Unprotect Password:="TITest1234"
End Sub

Public Sub resetExcel()
    Application.EnableEvents = True
    ActiveSheet.EnableCalculation = True
    Application.ScreenUpdating = True
End Sub