Oprettelse af nye worksheets i workbook med forskellige navne

Eksempel:
sheet1 = "Grunddata"
A          B          C            D              E
Idnr        Dato        Navn        Højde          Vægt 
010770      210800      Jens        180            80
201185      250800      Katrine      167            65
020890      030900      Lise        160            55
010770      220800      Jens        180            82

sheet2 = "Jens 010770"
A          B          C            D              E
Idnr        Dato        Navn        Højde          Vægt 
010770      210800      Jens        180            80
010770      220800      Jens        180            82

sheet3 = "Katrine 201185"
A          B          C            D              E
Idnr        Dato        Navn        Højde          Vægt 
201185      250800      Katrine      167            65

Osv.

Grunddata skal kunne opdateres hver måned, og jeg forestiller mig en CommandButton kan udføre opdelingen.

Håber denne forklaring gør at nogen bider på :-)

Hej Maria,

Nedenstående er et forslag til en mulig løsning.

Den er lavet som to Makroer.

Den første (Ny_bruger) skal bruges hvis der skal oprettes en ny bruger til regnearket, og den anden (Vaegt) bruges til at opdatere alle arkene.

Du kan jo se om det er noget du kan bruge...

Sub Ny_bruger()
   
    Dim ID As String
    Dim Dato As String
    Dim Navn As String
    Dim Højde As Long
    Dim Vægt As Long
    Dim Ark As String
   
    ID = InputBox("Indtast ID-nummer")
    Dato = InputBox("Indtast Dato")
    Navn = InputBox("Indtast navn")
    Højde = InputBox("Indtast Højde")
    Vægt = InputBox("Indtast Vægt")
   
    Sheets("Grunddata").Select
    Ark = (ID) & (" ") & (Navn)
    Sheets.Add.Name = Ark
    Sheets("Grunddata").Select
    Cells(1, 1).Select
    Selection.End(xlDown).Activate
    ActiveCell.Offset(1, 0).Activate
    ActiveCell = 0
    Columns(1).Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 2), TrailingMinusNumbers:=True
    Cells(1, 1).Select
    Selection.End(xlDown).Activate
    ActiveCell = ID
    ActiveCell.Offset(0, 1).Activate
    ActiveCell = 0
    Columns(2).Select
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 2), TrailingMinusNumbers:=True
    Cells(1, 2).Select
    Selection.End(xlDown).Activate
    ActiveCell = Dato
    ActiveCell.Offset(0, 1).Activate
    ActiveCell = Navn
    ActiveCell.Offset(0, 1).Activate
    ActiveCell = Højde
    ActiveCell.Offset(0, 1).Activate
    ActiveCell = Vægt
    Cells(1, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets(Ark).Select
    ActiveSheet.Paste
    Cells(1, 1).Select
    ActiveCell.Offset(1, 0).Select
    Sheets("Grunddata").Select
    Cells(1, 1).Select
    Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets(Ark).Select
    ActiveSheet.Paste
    Cells(2, 1).Select
    Cells(1, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Cells(2, 1).Select
    Sheets("Grunddata").Select
    Cells(2, 1).Select
    Application.CutCopyMode = False
End Sub


Og herunder kommer så makroen til at opdatere alle bruger-arkene.

Sub Vaegt()

    Dim ID As String
    Dim Navn As String
    Dim RK As Long
    Dim Ark As String
   
   
    RK = 2
   
    Do
    Cells(RK, 2).Select
    ID = Cells(RK, 1)
    Navn = Cells(RK, 3)
    Ark = (ID) & (" ") & (Navn)
    Sheets(Ark).Select
    Cells(1, 1).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    Sheets("Grunddata").Select
    Cells(RK, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets(Ark).Select
    ActiveSheet.Paste
    Cells(1, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Cells(2, 1).Select
    Sheets("Grunddata").Select
    RK = RK + 1
    If ActiveSheet.Name <> ("Grunddata") Then
    ActiveSheet.Next.Activate
    Else
    End If
    Loop Until Cells(RK, 1) = ""
    Application.CutCopyMode = False
    Cells(2, 1).Select
End Sub


Håber du kan få det til at virke.

Med venlig hilsen

Henrik