Excel - zamezení vložení duplicitních dat Vyřešeno

[PNkolona]

Vkládám data do databáze v excelu pomocí useformu s textboxsem (jména, příjmení, datum narození). Potřeboval bych, aby pokud při vložení budou zjištěna stejná data jsem mohl např. msboxem potvrdit, nebo zrušit vložení do tabulky.

[Reklama]

[navstevnik]

Obecna odpoved je, ze lze a to pomoci procedury VBA, ktera prohleda databazi. V udalostni procedure reagujici na stisk vkladaciho tlacitka prohledat data v tabulce, v pripade duplicity msgbox, jinak data ulozit.
Pro konkretni reseni priloz vzorovy soubor obsahujici formular a tabulku vcetne jiz napsanych prislusnych procedur. Zaroven uved "rozsah " duplicity, zda cely zaznam (vsechny polozky) nebo jen nektere.
Je potreba pocitat s tim, ze se zvetsujicim se poctem zaznamu v databazi bude narustat doba potrebna k overeni.

[PNkolona]

Vlastní databáze bude mít okolo 500 položek a napadlo mě, že by šlo data vložit, pak zjistit, že se data ve všech třech sloupcích neshoduji -akce nic - shodují - vyžádat potvrzení msboxem k pokračování (nechání dat), nebo "nevložení" smazání posledního vloženého řádku. Přikládám soubor.

[navstevnik]

V editoru VBA vloz do modulu UserForm1 tyto upravene procedury (oprav si diakritiku):

Kód: Vybrat vše

Option Explicit

Private Sub CommandButton1_Click()
  Dim TBlk As Range, TCll As Range
  Dim firstAddress As String

  If TextBox1.Value = "" Then
    MsgBox "Vyplòte prosím pole jméno"
    TextBox1.SetFocus
    Exit Sub
  End If

  If TextBox2.Value = "" Then
    MsgBox "Vyplòte prosím pole pøíjmení"
    TextBox2.SetFocus
    Exit Sub
  End If

  If TextBox3.Value = "" Then
    MsgBox "Vyplòte prosím pole datum narození"
    TextBox3.SetFocus
    Exit Sub
  End If

  If Not IsDate(TextBox3.Value) Then
    MsgBox "Vyplňte prosím správně pole datum narození"
    TextBox3 = vbNullString
    TextBox3.SetFocus
    Exit Sub
  End If

  ' blok dat na list1!B:B
  With Worksheets("list1")
    Set TBlk = .Range(.Range("b1"), .Range("b1").End(xlDown))
  End With
  ' prohledat blok
  With TBlk
    Set TCll = .Find(TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)  ' sloupec B:B
    If Not TCll Is Nothing Then
      firstAddress = TCll.Address
      Do
        If TextBox2.Value = TCll.Offset(0, 1).Value Then  ' sloupec C:C
          If DateValue(TextBox3.Value) = DateValue(TCll.Offset(0, 2).Value) Then  ' sloupec D:D
            MsgBox "Duplicitni zaznam": GoTo ErrHandler
          End If
        End If
        Set TCll = .FindNext(TCll)
      Loop While Not TCll Is Nothing And TCll.Address <> firstAddress
    End If
  End With
  ' cilova bunka pro vlozeni dat
  Set TCll = TBlk.Resize(1, 1).Offset(TBlk.Rows.Count, 0)
  ' vlozit data
  TCll.Value = TextBox1.Value
  TCll.Offset(0, 1).Value = TextBox2.Value
  TCll.Offset(0, 2).Value = TextBox3.Value
  ' vyprazdnit textboxy
  TextBox1.Text = vbNullString
  TextBox2.Text = vbNullString
  TextBox3.Text = vbNullString
ErrHandler:
  Set TCll = Nothing
  Set TBlk = Nothing

End Sub

Private Sub CommandButton2_Click()
  ' vyprazdnit textboxy
  TextBox1.Text = vbNullString
  TextBox2.Text = vbNullString
  TextBox3.Text = vbNullString
UserForm1.Hide
End Sub

Do bunky list1!A3 vloz vzorec (puvodni vzorec je zbytecne slozity): =KDYŽ(B3="";"";A2+1) a kopiruj dolu dle potreby. Tlaciko na listu2 pouzij z Ovladacich prvku nikoliv z Formulare. U nazvu ovladacich prvku se rid podle: http://www.officir.ic.cz/chipex05/07/ex ... _form.html ,je to prehlednejsi a lepe se orientuje ve slozitejsim formulari.

[PNkolona]

Funguje to skvěle, pouze se zeptám je možnost, aby se při duplicitních záznamech zeptal a já se mohl rozhodnout zda je přesto nevložit a dále jak nastavit kurzor pro psaní do textbox1.

[navstevnik]

Pro zobrazeni kurzoru pri inicializaci pouzij proceduru:

Kód: Vybrat vše

Sub tlačítko1_Klepnutí()
  With UserForm1
    .Show vbModeless
    .TextBox1.SetFocus
  End With
End Sub

Pro moznost vlozeni duplicitniho zaznamu vloz do UserForm1 CheckBox:
Name: chkVloz - odkazuji procedury
Caption: Vlozit duplicitni zaznam

Dale ve formulari zrus Frame pro textboxy a pro nadepsani pouzij Label.

Ve formulari usporadej poradi presunu fokusu pro Tab: aktivni navrh formulare>nabidka View>TabOrder>usporadej TextBox1, TextBox2,.. tlacitka, chkVloz >OK

Upravene procedury:

Kód: Vybrat vše

Option Explicit

Private Sub CommandButton1_Click()
  Dim TBlk As Range, TCll As Range
  Dim firstAddress As String

  If TextBox1.Value = "" Then
    MsgBox "Vyplòte prosím pole jméno"
    TextBox1.SetFocus
    Exit Sub
  End If

  If TextBox2.Value = "" Then
    MsgBox "Vyplòte prosím pole pøíjmení"
    TextBox2.SetFocus
    Exit Sub
  End If

  If TextBox3.Value = "" Then
    MsgBox "Vyplòte prosím pole datum narození"
    TextBox3.SetFocus
    Exit Sub
  End If

  If Not IsDate(TextBox3.Value) Then
    MsgBox "Vyplòte prosím správnì pole datum narození"
    TextBox3 = vbNullString
    TextBox3.SetFocus
    Exit Sub
  End If

  ' blok dat na list1!B:B
  With Worksheets("list1")
    Set TBlk = .Range(.Range("b1"), .Range("b1").End(xlDown))
  End With
  If Not chkVloz Then ' vlozit neduplicitni zaznam
    ' prohledat blok
    With TBlk
      Set TCll = .Find(TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)  ' sloupec B:B
      If Not TCll Is Nothing Then
        firstAddress = TCll.Address
        Do
          If TextBox2.Value = TCll.Offset(0, 1).Value Then  ' sloupec C:C
            If DateValue(TextBox3.Value) = DateValue(TCll.Offset(0, 2).Value) Then  ' sloupec D:D
              MsgBox "Duplicitni zaznam": GoTo ErrHandler
            End If
          End If
          Set TCll = .FindNext(TCll)
        Loop While Not TCll Is Nothing And TCll.Address <> firstAddress
      End If
    End With
  End If
  ' cilova bunka pro vlozeni dat
  Set TCll = TBlk.Resize(1, 1).Offset(TBlk.Rows.Count, 0)
  ' vlozit data
  TCll.Value = TextBox1.Value
  TCll.Offset(0, 1).Value = TextBox2.Value
  TCll.Offset(0, 2).Value = TextBox3.Value
  ' vyprazdnit textboxy
  TextBox1.Text = vbNullString
  TextBox2.Text = vbNullString
  TextBox3.Text = vbNullString
  chkVloz.Value = False
  TextBox1.SetFocus
ErrHandler:
  Set TCll = Nothing
  Set TBlk = Nothing

End Sub

Private Sub CommandButton2_Click()
' vyprazdnit textboxy
  TextBox1.Text = vbNullString
  TextBox2.Text = vbNullString
  TextBox3.Text = vbNullString
  chkVloz.Value = False
  UserForm1.Hide
End Sub

[PNkolona]

Děkuji, funguje tak jak jsem potřeboval.No mám se co učit.