Excel-VBA Duplicita_OddelitText

Muzes pouzit udalostni proeduru viz nize, ktera overi duplicitu v bloku bunek C3:C24, pokud vlozena data vyhovuji, vlozi do odpovidajici bunky v B:B levou cast retezce po mezeru. Dale je osetreno vkladani do vice bunek najednou.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Tmp As Variant
  With Target
    If .Cells.Count = 1 Then
      If .Value <> vbNullString Then
        If Not Intersect(Target, Me.Range("c3:c24")) Is Nothing Then
          If Application.WorksheetFunction.CountIf(Range("c3:c24"), .Value) < 2 Then
            Tmp = Split(.Value, " ")
            .Offset(0, -1).Value = Tmp(0)
          Else
            MsgBox "Duplicitni zadani"
            With Application
              .EnableEvents = False
              Target.Value = vbNullString
              .EnableEvents = True
            End With
          End If
        End If
      End If
    Else
      Dim Cll As Range, i As Integer
      i = 0
      For Each Cll In Target.Cells
        If Cll <> vbNullString Then i = i + 1
      Next Cll
      Set Cll = Nothing
      If i > 0 Then
        MsgBox "Nelze vlozit data do vice bunek najednou"
        With Application
          .EnableEvents = False
          Target.Value = vbNullString
          .EnableEvents = True
        End With
      End If
    End If
  End With
End Sub

Dakujem za skoru odpoved. Ja odpovedam trosku neskorsie, pretoze som riesenie overoval. Podstatu mojho problemu riesenie splna, ale:
1. Data sa mozu vkladat len ako text, co som mozno v zadani nie jednoznacne zadefinoval a zdoraznil, preto som chcel vkladanie dvojklikom mysou. Vkladanie cez Vlozit (Paste)nesmie byt, co uzivatelovi nemozem zabranit. Poprosil by som tuto dodatocnu poziadavku zakomponovat do makra pokial to ide - dakujem.
2. Po zadani duplicity do vyplnenej bunky v stlpci C a akceptovani Msgboxu, sa obsah tejto bunky vynuluje. Tak ako zostane udaj v zodpovedajucej bunke v stlpci B, musi zostat aj povodny obsah v stlpci C - uzivatel sa mohol pomylit.
3. Duplicitna bunka alebo hodnota sa nevysvieti (nezafarbi)
4. Snazil som sa otestovat vkladanie do viac bunek najednou, ale sa mi to nedarilo. Ak som vybral dve bunky v stlpci C3:C24 a pokusil sa vlozit text zo schranky, upozornilo ma "Data v schranke nie su zhodneho rozsahu ..." a nie ako je to v makre. Asi som nepochopil tvoju myslienku.

Omlouvam se za zpozdeni s odpovedi,byl jsem mimo domov.
Procedury v modulu listu.
Zabrana rucniho vlozeni dat do C3:C24:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Me.Range("c3:c24")) Is Nothing Then
    If Target.Value <> vbNullString Then
      MsgBox "Nelze rucne zapisovat data do oblasti C3:C24"
      With Application
        .EnableEvents = False
        .Undo
        .EnableEvents = True
      End With
    End If
  End If
End Sub

vkladani z clipboardu - dvojklik na cilovou bunku v C3:C24, je nutné nastavit odkaz na Microsoft Forms 2.0 Object Library: VBA>Tools>References...:

' je nutné nastavit odkaz na Microsoft Forms 2.0 Object Library: VBA>Tools>References...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim DataObj As New MSForms.DataObject
  Dim Tmp As Variant, OldData As String
  With Target
    If .Cells.Count = 1 Then
      If Not Intersect(Target, Me.Range("c3:c24")) Is Nothing Then
        OldData = .Value ' stara data ulozit
        ' vlozit data z clipboardu
        DataObj.GetFromClipboard
        Application.EnableEvents = False
        Tmp = Split(DataObj.GetText, " ")
        .Value = DataObj.GetText
        ' overit duplicitu
        If Application.WorksheetFunction.CountIf(Range("c3:c24"), .Value) > 1 Then
          .Interior.ColorIndex = 3 ' zvyraznit bunku
          MsgBox "Duplicitni zadani"
          .Value = OldData ' obnovit data a pozadi
          .Interior.ColorIndex = xlNone
        Else
          ' vlozit do B:B levou cast retezce po mezeru
          .Offset(0, -1).Value = Tmp(0)
        End If
        Application.EnableEvents = True
        .Offset(0, -1).Select
      End If
    End If
  End With
  Set DataObj = Nothing
End Sub

Snad to bude vyhovovat.

Dakujem pekne, uz som ani necakal odpoved. Pouzivam MS Excel 2007 a odkaz na Microsoft Forms 2.0 Object Library nemozem najst v References. Neviem ci 2007 tuto kniznicu podporuje.Alebo sa mylim? Tym nemozem makro odskusat.

Pri trose hledani na Googlu bys nasel: http://p2p.wrox.com/excel-vba/5118-how-get-microso ft-forms-2-0-object-library.html
Postup: Tools>References>Browse a najit soubor FM20.dll a Otevrit.

Ospravedlnujem sa za nehladanie v Googli.
Dakujem za straveny cas pri tvoreni makra - si fachman, klobuk dole. Makro funguje az na jeden detail, ktory som objavil celkom nahodne. Omylom som 2x klikol na bunku v rozsahu C3:C24 vtedy, ked schranka bola prazdna. Vypisala sa chyba: Run-time error'-2147221404 (80040064)': DataObject:GetText Neplatná struktura FORMATETC. Potom uz makro nepracovalo, musel som zosit zavriet a znovu otvorit.
Islo by zaradit kontrolu schranky ci je prazdna predtým, ako vlozim text do bunky v C stlpci? Dat nejaky Msg o tom, ze chranka je prazdna.

Nemusis se omlouvat za nehledani na Googlu, spis se omlouvam ja, ze jsem dusledne neosetril stav, kdy je clipboard prazdny.
Procedura po vznikle chybe a ukonceni behu celkem zakonite nemohla pri opakovanem zavolani pracovat, nebot nedoslo v dusledku predcasneho ukonceni procedury k obnove zachytavani udalosti nenastavenim vlastnosti Application.EnableEvents = True. Pro takovyto pripad staci pouzit proceduru:

Sub AEE()
Application.EnableEvents = True
End Sub

Procedura Private Sub Worksheet_BeforeDoubleClick je doplnena o kontrolu, zda neni clipboard prazdny a upravena, nahrad predchozi proceduru:

' je nutné nastavit odkaz na Microsoft Forms 2.0 Object Library: VBA>Tools>References...
' Excel 12 Tools>References>Browse a najit soubor FM20.dll a Otevrit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim DataObj As New MSForms.DataObject
  Dim Tmp As Variant, OldData As String, OldIntCol As Integer
  Dim TmpStr As String, Response As Byte

  With Target
    If .Cells.Count = 1 Then
      If Not Intersect(Target, Me.Range("c3:c24")) Is Nothing Then
        OldData = .Value  ' stara data ulozit
        OldIntCol = .Interior.ColorIndex
        ' obsah clipboardu a kontrola neprazdnosti
        DataObj.GetFromClipboard
        TmpStr = Trim(DataObj.GetText)
        If TmpStr = vbNullString Then
          Response = MsgBox("Clipboard je prazdny", vbExclamation)
        Else
          Application.EnableEvents = False
          ' vlozit data z clipboardu
          .Value = TmpStr
          ' overit duplicitu
          If Application.WorksheetFunction.CountIf(Range("c3:c24"), .Value) > 1 Then
            .Interior.ColorIndex = 3  ' zvyraznit bunku
            Response = MsgBox("Duplicitni zadani", vbExclamation)
            .Value = OldData  ' obnovit data a pozadi
            .Interior.ColorIndex = OldIntCol
          Else
            ' vlozit do B:B levou cast retezce po mezeru
            Tmp = Split(TmpStr, " ")
            .Offset(0, -1).Value = Tmp(0)
          End If
          Application.EnableEvents = True
        End If
        .Offset(0, -1).Select
      End If
    End If
  End With
  Set DataObj = Nothing
  Exit Sub
End Sub

Vdaka za odpoved, ale v pripade ked je clipboard prazdny, opat dojde k Run time error 2147221404(80040064):
DataObject:Get Text Neplatna struktura FORMATETC.
Nedoslo ani k Msg "Clipboard je prazdny". Pri Debugu ostal vysvieteny prikaz:
TmpStr = Trim(DataObj.GetText)
Po Endovani hlasky, s makrom sa dalej dalo pracovat.

Funkcnost jsem testoval v Excel 2000 (.xls) tak i v Excel 2007 (.xlsm), vzdy funkcni. Ovsem je otazkou, jak byl ziskan "prazdny" clipboard.
Takze dopln proceduru o vyznacene radky pred a za inkriminovanym radkem:
...
On Error Resume Next
TmpStr = Trim(DataObj.GetText)
On Error GoTo 0
...

BINGOOOOOOOO!!!
Funguje to presne tak, ako som potreboval. Srdecna vdaka za riesenie. Vela uspechov v Tvojej tvorivej praci. Cheers, superman.