< návrat zpět

MS Excel


Téma: Vyhledávání buňky s diakritikou rss

Zaslal/a 26.6.2018 13:58

Ahoj všem,
prosím, potřeboval bych poradit. Potřebuji v excelu v určitém sloupci vyhledat a označit (třeba žlutou barvou) pouze buňky, které obsahují pouze češtinu (diakritiku).
Prosím, poradíte někdo s makrem?
Předem díky

Zaslat odpověď >

icon #040811
eLCHa
Zkuste tento vzorec - teoreticky by mohl stačit (testoval jsem jen na pár slovech)
Maticově
=MAX(KÓD(ČÁST(A1;ŘÁDEK($A$1:INDEX($A:$A;DÉLKA(A1)));1)))>KÓD("z")
testované slovo je v A1citovat
#040822
avatar
Dobrý den
děkuji za zaslaný vzorec ale pro moji potřebu nestačí.
Na jiných stránkách jsem našel makro, které odstraňuje diakritiku, makro jsem si upravil pro odstraňování diakritiky ve sloupcích H a X viz níže:

Sub diakritika_sloupec_H_X()

Dim Oblast As Range
Dim PoleS()
Dim PoleBez()

PoleS = Array("Ä", "Á", "Č", "Ď", "É", "Ě", "Í", "Ĺ", _
"Ň", "Ö", "Ó", "Ř", "Š", "Ť", "Ü", "Ú", "Ů", "Ý", "Ž", _
"ä", "á", "č", "ď", "é", "ě", "í", "ĺ", "ň", "ö", "ó", _
"ř", "š", "ť", "ü", "ú", "ů", "ý", "ž")
PoleBez = Array("A", "A", "C", "D", "E", "E", "I", "L", _
"N", "O", "O", "R", "S", "T", "U", "U", "U", "Y", "Z", _
"a", "a", "c", "d", "e", "e", "i", "l", "n", "o", "o", _
"r", "s", "t", "u", "u", "u", "y", "z")

Set Oblast = ActiveSheet.Range("H12:H15000", "X12:X15000")
For i = 0 To 37
Oblast.Replace What:=PoleS(i), Replacement:=PoleBez(i), _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Next i

End Sub

Potřebuji toto makro ale upravit tak, aby se diakritika neodstraňovala, ale aby se buňky, které obsahují diakritiku, označily např. žlutou barvou.citovat
icon #040825
eLCHa
ale pro moji potřebu nestačí.

Já neznám vaši potřebu. A nebudu ji z vás dolovat.citovat
#040852
elninoslov
Ja by som to videl nejako takto. Je to ale špecializované na jednostĺpcové oblasti, tak ako ste chcel.
Sub Oznac_diakritiku_v_oblasti(Oblast As Range)
Dim USlova, USpolu As String, Nahrad() As String, i As Long, UZnak As String * 1, poz As Long, Dlzka As Long, Pokracuj As Boolean, RNG As Range, Riadkov As Long
Const ODDEL = "•#$" 'Jednoznačný oddeľovač buniek

With Oblast
.ClearFormats 'Vymaže doterajší formát
Riadkov = .Cells(.Rows.Count).End(xlUp).Row - .Row + 1 'Budú sa skúmať iba vyplnené riadky
Select Case Riadkov
Case Is < 0: Exit Sub
Case Is > 1: USpolu = UCase(Join(WorksheetFunction.Transpose(Oblast), ODDEL)) 'Spojenie a prevod na UCASE
Case 1: USpolu = UCase(.Cells(1))
End Select

Nahrad = Split("A•B•C•D•E•F•G•H•I•J•K•L•M•N•O•P•Q•R•S•T•U•V•W•X•Y•Z", "•") 'Pre niektoré prípady bude možno lepšie vyradiť aj iné znaky, viď nižšie. Ale niekedy to je zase kontrproduktívne.
'Nahrad = Split("A•B•C•D•E•F•G•H•I•J•K•L•M•N•O•P•Q•R•S•T•U•V•W•X•Y•Z•0•1•2•3•4•5•6•7•8•9•+•-•*•/•=•?•!•(•)•.•_•:•;•,", "•")
For i = 0 To UBound(Nahrad) 'Vynechanie znakov
If Not InStr(USpolu, Nahrad(i)) Then USpolu = Replace(USpolu, Nahrad(i), vbNullString)
Next i
USlova = Split(USpolu, ODDEL) 'Rozdeľ naspäť prečistené

For i = 0 To UBound(USlova)
Dlzka = Len(USlova(i)) 'Zistí dĺžku reťazca, pre ukončenie

If Dlzka > 0 Then
poz = 1
Pokracuj = True

While Pokracuj
UZnak = Mid$(USlova(i), poz, 1) 'Po jednom znaku kontroluj
If StrComp(UZnak, LCase(UZnak), vbBinaryCompare) = 0 Then 'ak nenájde rozdiel medzi UCASE a LCASE znaku, nieje to určite diakritika, lebo ostatné písmená sme vyradili už skôr, a je to nejaký iný znak
poz = poz + 1
If poz > Dlzka Then Pokracuj = False 'Ak bolo posledné písmeno, ukonči
Else
Pokracuj = False
If RNG Is Nothing Then Set RNG = .Cells(i + 1) Else Set RNG = Union(RNG, .Cells(i + 1)) 'a ak nájde rozdiel medzi UCASE a LCASE znaku, je to určite diakritika, a teda priraď do výslednej oblasti
End If
Wend

End If
Next i
End With

If Not RNG Is Nothing Then RNG.Interior.Color = vbYellow 'Vyfarbiť
End Sub


Sub Oznac()
With ThisWorkbook.Worksheets("Hárok1")
Oznac_diakritiku_v_oblasti .Range("H12:H15000") '1. jednostĺpcová oblasť
Oznac_diakritiku_v_oblasti .Range("X12:X15000") '2. jednostĺpcová oblasť
End With
End Sub


EDIT:
Prípadne to "jadro pudla" - While->Wend, vymeniť za asi o 2% rýchlejší variant
While Pokracuj
UZnak = Mid$(USlova(i), poz, 1) 'Po jednom znaku kontroluj
Select Case True
Case Asc(UZnak) < 128: poz = poz + 1: Pokracuj = poz <= Dlzka 'Kontrola iba znakov >127, Ak bolo posledné písmeno, ukonči
Case StrComp(UZnak, LCase(UZnak), vbBinaryCompare) = 0: poz = poz + 1: Pokracuj = poz <= Dlzka 'ak nenájde rozdiel medzi UCASE a LCASE znaku, nieje to určite diakritika, lebo ostatné písmená sme vyradili už skôr, a je to nejaký iný znak, Ak bolo posledné písmeno, ukonči
Case Else: Pokracuj = False: If RNG Is Nothing Then Set RNG = .Cells(i + 1) Else Set RNG = Union(RNG, .Cells(i + 1)) 'a ak nájde rozdiel medzi UCASE a LCASE znaku, je to určite diakritika, a teda priraď do výslednej oblasti
End Select
Wend
Příloha: zip40852_oznac-bunky-s-diakritikou.zip (258kB, staženo 3x)
citovat
#040853
avatar
Pokiaľ som porozumel tomuto skvelému zadaniu, tak chceš označiť iba bunky s českou diakritikou. Bunky so slovenskou diakritikou alebo nemeckou už zrejme nie. No toto netuším ako riešiť. Jedine nahrať komplet český slovník a porovnávať každé slovo. Možno elninoslov to dá.citovat
#040854
elninoslov
Aha. No ak je to tak, tak potom nie použiť StrComp(), ale definovať si reťazec českých znakov UCASE(), a použiť InStr(). Ale zatiaľ to prerábať nebudem, počkám na vyjadrenie Raptora-22.citovat
#040859
avatar
Zdravím
chtěl bych poděkovat za makro od "elninoslov". Makro je výborné, plně funkční :-). Díky.
Potřeboval jsem označit buňky, které obsahují diakritiku (háčky, čárky, dvojtečky atd.) a toto makro to zvládá v pohodě. Ještě jednou díky, hodně dobrá práce..citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

Spuštění makra, když buňka větší než...

slavekskeeve • 17.10. 9:44

Spuštění makra, když buňka větší než...

elninoslov • 17.10. 8:58

Odeslání listu na e-mail

elninoslov • 17.10. 8:46

Spuštění makra, když buňka větší než...

slavekskeeve • 17.10. 8:38

Odeslání listu na e-mail

lubo1 • 17.10. 8:26

Odeslání listu na e-mail

elninoslov • 16.10. 20:55

Odeslání listu na e-mail

Pavel-Krivanek • 16.10. 10:44