Automatisk kopiering af data til andet faneblad

Hvad skal der ske, hvis du taster et navn i hovedarket, som ikke allerede har et selvstændigt ark?

Det er muligt, men det kræver nok en makro, som du kan tilknytte til en knap.

Denne makro forudsætter at dine ark er ens i opbygning og at du har et tomt ark kun med overskrifterne. Arket kaldes Blank. Efternavne står i kolonne B (2)

Den linie du står i bliver overført til arket med samme efternavn, hvis det findes ellers bliver du spurgt om det skal oprettes. Hvis du svarer Ja til det, oprettes et ark med pågældende efrnavn og linien kopieres over

Sub TransferName()

    Const lLastNameColumn  As Long = 2
    Const stTemplate      As String = "Blank"
    Dim rng                As Range
    Dim wks                As Worksheet
    Dim wksA              As Worksheet
    Dim bFound            As Boolean
    Dim answer


    Set wksA = ActiveSheet
    Set rng = Cells(ActiveCell.Row, lLastNameColumn)
    If IsEmpty(rng) Then Exit Sub
    For Each wks In ActiveWorkbook.Worksheets
        If UCase(wks.Name) = UCase(rng.Value) Then
            rng.EntireRow.Copy Destination:=wks.Range("A65536").End(xlUp).Offset(1, 0)
            bFound = True
            Exit For
        End If
    Next

    If Not bFound Then
        answer = MsgBox("Der mangler et faneblad for " & rng.Value & vbCr & _
                        "Skal efternavnet oprettes som faneblad ?", vbCritical + vbYesNo)
        If answer = vbYes Then
            Sheets(stTemplate).Copy before:=ActiveWorkbook.Sheets(Sheets.Count)
            ActiveSheet.Name = rng.Value
            rng.EntireRow.Copy Destination:=ActiveSheet.Range("A2")
            wksA.Activate
            MsgBox "Ark " & rng.Value & " er oprettet og " & rng.Offset(0, -1) & " " & _
                    rng.Value & " er nu overført", vbInformation
        End If
    Else
        MsgBox rng.Offset(0, -1) & " " & rng.Value & " er nu overført", vbInformation
    End If

End Sub

Prøv med

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo notfound
If Target.Column = 1 Then
    Target.Rows.EntireRow.Copy
    findark = Target.Value
    Sheets(findark).Activate
    Sheets(findark).Range("a1").Select
    If IsEmpty(Sheets(findark).Range("a2")) Then
        Sheets(findark).Range("a2").Select
        ActiveSheet.Paste
        Exit Sub
    Else
        Selection.End(xlDown).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Application.CutCopyMode = False
Exit Sub
notfound:
    If Err.Number = 9 Then
        Worksheets.Add
        NytArkNavn = ActiveSheet.Name
        Sheets(NytArkNavn).Name = findark
        Sheets(findark).Range("a2").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
    Else
        MsgBox Err.Description
    End If
End If

bak-> Ja, man skal se sig for, ellers kommer man forsent :-)

Jeps, ellers nogenlunde samme opbygning, så vi må være på sporet :-)
Ser at du har brugt Worksheet_Change på column 1....Overfører den så ikke før adressen er tastet ind ?

kan forøvrigt godt se at (når jeg ser din) at min løkke for at finde arket er overflødig...kunne have nøjes med Sheets(findark).Activate

bak-> Jo, i min test ventede med navnet til sidst :-)
Hvis det skal ske automatisk, når navnet indtastes, må navnet nødvendigvis være det sidste, der indtastes.

Ellers skal kolonnen bare rettes til, der nu tastes sidst.