30. april 2011 - 05:07
#2
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
