Tal mellem 1-1000, der ikke forekommer i kolonne

Ikke userform men Inputbox:

Der spørges efter et tal mellem 1 og 10000
der kontrolleres om tallet findes i kolonne A1:A10001
Hvis ikke oprettes dette i A1:A10001 nederst

Jeg skulle have oplyst bedre, i hvilken sammenhæng, det skal bruges. På min userform er der en tekstbox, hvor man skriver et givent tal.Når man forlader boksen, skal der tjekkes om tallet er brugt - hvis det er brugt, er det fint med meddelsen og retur til tekstboksen. Hvis det ikke er brugt, skal man kunne gå videre med at udfylde de øvrige tekstbokse (2 stk.) for til sidst at sætte alle data ind på første ledige plads efter øvrige data, som du også gør.

Det var også kun et eksempel.
Er det "fri" tekst i de 2 tekstbokse?
Send evt. på mail

Den ene er en "datoboks" den anden til kommentarer, men den vi taler om skal indeholde unikke værdier. Senere regner jeg med, at der kommer flere tekstbokse til.

Fin løsning Store-Morten - lægger du et svar?



Private Sub CommandButton1_Click()
Dim rCell As Range
Dim rOmraade As Range
Dim Kontrol As String
On Error GoTo ErrorHandle

'Rangevariablen sættes = celle A2
Set rOmraade = Range("A2")

'Hvis der står noget i cellen nedenunder (A2),
'udvides rOmraade nedad til den sidste celle
'med indhold. Dette svarer til CTRL + SHIFT + pil ned.
If Len(rOmraade.Offset(1, 0).Formula) > 0 Then
  Set rOmraade = Range(rOmraade, rOmraade.End(xlDown))
End If

'Hvis Textbox1 er tom gås til linien til Tom:
If TextBox1.Value = "" Then
    GoTo Tom
    Exit Sub
Else
'Hvis Textbox1 ikke er tom farves hvid
TextBox1.BackColor = RGB(255, 255, 255)
End If

'Hvis Textbox1 er >1000 gås til linien til TalOver1000:
If TextBox1.Value > 1000 Then
GoTo TalOver1000
    Exit Sub
End If

'Hvis Textbox1 er <1 gås til linien til TalUnder1:
If TextBox1.Value < 1 Then
GoTo TalUnder1
    Exit Sub
End If

Kontrol = TextBox1.Value

'Nu gennemløbes området celle for celle.
'Hvis indholdet findes
'Stoppes og Textbox1 tømmes.
For Each rCell In rOmraade
    If rCell.Value = Kontrol Then
      GoTo TalMatch
      Exit Sub
    End If
Next

With ActiveCell
    .Offset(0, 0).Value = TextBox1.Text
    .Offset(0, 1).Value = TextBox2.Text
    .Offset(0, 2).Value = TextBox3.Text
    End With

TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
  Range("A2").CurrentRegion.Select
    ActiveCell.Offset(Selection.Rows.Count, 0).Activate
   
BeforeExit:
'Rangevariablerne fjernes fra hukommelsen.
Set rCell = Nothing
Set rOmraade = Nothing
'Set Kontrol = Nothing
Exit Sub
ErrorHandle:
'MsgBox Err.Description & ", Der opstod en fejl", "Fejl"
Resume BeforeExit

Tom:
MsgBox "Du skal skrive et tal" & vbCrLf & _
"Mellem 1 og 1000" & vbCrLf & _
"Vælg et nyt"
TextBox1.Value = ""
TextBox1.BackColor = RGB(255, 255, 150)
TextBox1.SetFocus
Exit Sub

TalOver1000:
MsgBox "Tallet er større end" & vbCrLf & _
"1000" & vbCrLf & _
"Vælg et nyt mindre end 1000"
TextBox1.Value = ""
TextBox1.BackColor = RGB(255, 255, 150)
TextBox1.SetFocus
Exit Sub

TalUnder1:
MsgBox "Tallet er mindre end" & vbCrLf & _
"1" & vbCrLf & _
"Vælg et nyt større end 1"
TextBox1.Value = ""
TextBox1.BackColor = RGB(255, 255, 150)
TextBox1.SetFocus
Exit Sub

TalMatch:
MsgBox "Tallet Findes i forvejen!" & vbCrLf & _
"Vælg et nyt"
TextBox1.Value = ""
TextBox1.BackColor = RGB(255, 255, 150)
TextBox1.SetFocus
Exit Sub

End Sub


Private Sub UserForm_Initialize()
Worksheets("Ark1").Activate
Range("A2").Select
If Range("A2").Value = "" Then
    Range("A2").Activate
Else
    Range("A2").CurrentRegion.Select
    ActiveCell.Offset(Selection.Rows.Count, 0).Activate
End If
'Sætter overskrift fra Ark1 på Userform
'Ret overskrift på Ark1 og Userform rettes
Label1.Caption = Range("A1").Value
Label2.Caption = Range("B1").Value
Label3.Caption = Range("C1").Value
End Sub

Velbekomme