iCentar » Forum » Racunari i oprema » Softver i operativni sistemi » Ms office » Kako da obrisem redove sa markiranim celijama

iCentar → Racunari i oprema → Softver i operativni sistemi → Ms office → Kako da obrisem redove sa markiranim celijama

Pretrazi
Tim
Registriraj se
Vazni alati
Razno. veze
- Oznaci forume kao procitane
- Smjernice
Aktivne teme ...
- u posljednja 24 sata
- od moje posljednje posjete
Vijesti (RSS, ...)
- RSS 2.0
- RSS 1.0
- OPML
- Klipfolio
- Atom 1.0
Prijavi se

Odgovori na temu

Korisnicko ime:

Adresa e-poste:

Sigurnosna provjera:
Unesite znakove na slici. Ovo bi trebalo izbjeci nezeljenu postu.

Predmet:

Objavi:

Pomoc

Boja

Velicina

vise smajlica

[quote=Avko][quote=White Man]Taj kod vec postoji u onom Vasem primeru, ja sam u taj fajl iskopirao tablicu i nece, obrise samo one prve koji postoje od pre. Iskopirao sam ponovo ovaj kod sa sajta i ponovo nece. Da nema neke veze sa nijansom boje? Meni je sam excel iz konditional/duplicate values obojio celije i sad trebam da obrisem redove. Excel je 2016 ako i to ima neke veze. Hvala unapred[/quote]

ima veze do color indexa, stavio sam 38 pa je obriso samo redove koji su imali 38. Postoji indexa 56 boja

idemo probati vidjeti koje se sve boje nalaze

pritisnes Alt+F11
izaberes iz menija insert + module
u taj modul ubacis ovaj kod:
(sada je to vec drugi modul modul2)

[code]
Sub ko****je()
    
    Dim lRow As Long
    Dim iCntr As Long
    Dim boje(56)
    lRow = ActiveSheet.UsedRange.Rows.Count
    For iCntr = lRow To 1 Step -1
        boje(ColorIndex(Cells(iCntr, 1))) = boje(ColorIndex(Cells(iCntr, 1))) + 1
    Next iCntr
    
    Dim txt As String
    
    For iCntr = 0 To 56
        If boje(iCntr) > 0 Then txt = txt & CStr(iCntr) & vbNewLine
        
    Next iCntr
    MsgBox txt
    
End Sub

'---------------------------------------------------------------------
' ColorIndex Function
'---------------------------------------------------------------------
' Function:    Returns the colorindex of the supplied range
' Synopsis:    Initially, gets a colorindex value for black and white
'              from the activeworkbook colour palette
'              Then works through each cell in  the supplied range and
'              determines the colorindex, and adds to array
'              Finishes by returning acumulated array
' Variations:  Determines cell colour (interior) or text colour (font)
'              Default is cell colour
' Constraints: Does not count colours set by conditional formatting
'---------------------------------------------------------------------
' Author:      Bob Phillips
'              Additions for ranges suggested by Harlan Grove
'---------------------------------------------------------------------

'---------------------------------------------------------------------
Function ColorIndex(Rng As Range, _
                    Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant

If Rng.Areas.Count > 1 Then
        ColorIndex = CVErr(xlErrValue)
        Exit Function
    End If

iWhite = WhiteColorindex(Rng.Worksheet.Parent)
    iBlack = BlackColorindex(Rng.Worksheet.Parent)

If Rng.Cells.Count = 1 Then
        If text Then
            aryColours = DecodeColorIndex(Rng, True, iBlack)
        Else
            aryColours = DecodeColorIndex(Rng, False, iWhite)
        End If

Else
        aryColours = Rng.Value
        i = 0

For Each row In Rng.Rows
            i = i + 1
            j = 0

For Each cell In row.Cells
                j = j + 1

If text Then
                    aryColours(i, j) = _
                      DecodeColorIndex(cell, True, iBlack)
                Else
                    aryColours(i, j) = _
                      DecodeColorIndex(cell, False, iWhite)
                End If

Next cell

Next row

End If

ColorIndex = aryColours

End Function

'---------------------------------------------------------------------
Private Function WhiteColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
    WhiteColorindex = 0
    For iPalette = 1 To 56
        If oWB.Colors(iPalette) = &HFFFFFF Then
            WhiteColorindex = iPalette
            Exit Function
        End If
    Next iPalette
End Function

'---------------------------------------------------------------------
Private Function BlackColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
    BlackColorindex = 0
    For iPalette = 1 To 56
        If oWB.Colors(iPalette) = &H0 Then
            BlackColorindex = iPalette
            Exit Function
        End If
    Next iPalette
End Function

'---------------------------------------------------------------------
Private Function DecodeColorIndex(Rng As Range, _
                                  text As Boolean, _
                                  idx As Long)
'---------------------------------------------------------------------
Dim iColor As Long
    If text Then
        iColor = Rng.Font.ColorIndex
    Else
        iColor = Rng.Interior.ColorIndex
    End If
    If iColor < 0 Then
        iColor = idx
    End If
    DecodeColorIndex = iColor
End Function

'---------------------------------------------------------------------
' End of ColorIndex Function
'---------------------------------------------------------------------

[/code]

pritisnes Alt+Q za povratak u normalni list
pritisnes Alt+F8 i sa popisa odaberes svoju makronaredbu ko****je
Pokreni

Sto je napisalo, koje brojeve?[/quote]

Povecaj velicinu · Smanji velicinu Provjeri duzinu

Opcije:

Pretvori smajlice u postu
Pretvori & quot; vokable & quot; u postu

Prilozi:

Upravljanje prilozima
Mozete priloziti 3 datoteke!

Posljednjih 15 postova u ovoj temi

Ova tema sadrzi vise od 15 postova. Kliknite ovdje da biste pogledali cijelu temu.

Avko (21.01.2019 17:52):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Citiraj White Man:

Kao da dobijem ovakvu kao u primeru uslovnom selekcijom sa vise kolona? Za jednu idem: conditional formatting/highlight cells rules/duplicate value i ok. Gde se ide za vise kolona? Hvala unapred

Molio bi te, kad stignes, da otvoris novo pitanje a ne da pitas ovdje a nismo jos ni staro zavrsili.

Evo excel sa 50000 redova ,
pronade duplikate, oboji ih, makne duplikate, a ostaje obojeni duplikat itd itd

spoji rarove kada ih skines, ne dozvoljava velike datoteke podizati na forum

White Man (15.01.2019 13:21):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Kao da dobijem ovakvu kao u primeru uslovnom selekcijom sa vise kolona? Za jednu idem: conditional formatting/highlight cells rules/duplicate value i ok. Gde se ide za vise kolona? Hvala unapred

Gjoreski (15.01.2019 12:20):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Postavi primer od tog excela

White Man (15.01.2019 11:12):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Evo sad je prihvatilo sliku. Nema funkcije ni formule, to je lager lista ima naziv artikla, model, boja, cena, stara cena, nova cena, planirana i jos neke kolone. Jel moze uslovno da pokaze duplikate sa vise kolona? Na primer da pokaze duplikate redova koji imaju iste kolone na primer naziv, model, stara cena. Hvala unapred

White Man (15.01.2019 11:07):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Nece da mi prihvati sliku da nakacim ne znam sto, kako ubacim pise da vec postoji i da trebam da izbrisem, probao sam i ime da promenim i format ali opet nece a nije ni velika 200KB. Kao gresku pokaze na broju 70 Enf if i markirano je zuto, ispod njega na broju 71 je jos jedno End if. Da ne trebam da obrisem jedno?

White Man (15.01.2019 10:54):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Nece da radi ovaj kod, odmah izbaci gresko

Avko (15.01.2019 10:27):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Jos jedno pitanje:

Sadrze li celije neke formule , tipa: =sum() ili nesto slicno?

Avko (14.01.2019 20:49):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

PreuzmiIzvorni kôd (Text):

Sub duplikati()
If obojiDuplikate = True Then
If obrisiDuplikate = False Then
MsgBox "GRESKA! u brisanju duplikata"
Stop
End If
Else
MsgBox "GRESKA! u bojanju duplikata"
Stop
End If
End Sub
Function obojiDuplikate() As Boolean
obojiDuplikate = False
Dim LLoop As Long
Dim LTestLoop As Long
Dim LClearRange As String
Dim Lrows As Long
Dim Lcol As Long
Dim LRange As String
'A kolona, vrijednosti
Dim LChangedValue As String
Dim LTestValue As String
'B kolona vrijednosti
Dim LChangedValueB As String
Dim LTestValueB As String
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Lrows=zadnjiRed
With ActiveSheet
Lrows = .Cells(Rows.count, "A").End(xlUp).Row
Lcol = .Cells(1, Columns.count).End(xlToLeft).Column
End With
LLoop = 2
'obrisi boje ispune
LClearRange = "A2:B" & Lrows
Range(LClearRange).Interior.ColorIndex = xlNone
'provjeri sve redove
While LLoop <= Lrows
LChangedValue = "A" & CStr(LLoop)
LChangedValueB = "B" & CStr(LLoop)
If Len(Range(LChangedValue).Value) > 0 Then
'Nadi jedinstvenu vrijednost
LTestLoop = 2
While LTestLoop <= Lrows
If LLoop <> LTestLoop Then
LTestValue = "A" & CStr(LTestLoop)
LTestValueB = "B" & CStr(LTestLoop)
'vrijednost je duplikat u drugoj celiji
If (Range(LChangedValue).Value = Range(LTestValue).Value) And (Range(LChangedValueB).Value = Range(LTestValueB).Value) Then
'postavi crvenu boju pozadine u A stupcu
Range(LChangedValue).Interior.ColorIndex = 3
Range(LTestValue).Interior.ColorIndex = 3
'postavi crvenu boju pozadine u B stupcu
'ovo netreba
Range(LChangedValueB).Interior.ColorIndex = 3
Range(LTestValueB).Interior.ColorIndex = 3
End If
End If
LTestLoop = LTestLoop + 1
Wend
End If
LLoop = LLoop + 1
Wend
obojiDuplikate = True
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Function
Function obrisiDuplikate() As Boolean
obrisiDuplikate = False
Dim rCell As Range
Dim rRange As Range
Dim lCount As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set rRange = Range("A1", Range("A" & Rows.count).End(xlUp))
lCount = rRange.Rows.count
For lCount = lCount To 1 Step -1
With rRange.Cells(lCount, 1)
If WorksheetFunction.CountIf(rRange, .Value) > 1 Then
.EntireRow.Delete
End If
End With
Next lCount
obrisiDuplikate = True
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Function

Avko (14.01.2019 18:43):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

prvo kad se zabijeli stisnuti ctrl+break da vidimo gdje se zaustavilo

White Man (14.01.2019 18:32):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Kad sam zamenio sa long radi malo duze, vidim vise redova kako markira i onda zamrze, a ovo druo kad god ubacim nesto ibaci mi gresku u kodu. Jel mozete da zameniti gde sve treba pa da nakacite ceo kod? Hvala unapred

Avko (14.01.2019 15:38):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Jesi isprobao primjer od Gjoreskog?
ako jesi i radi to je to a ako jesi i opet se smrzne probaj ovo:

na pocetku svake funkcije ubaci ovo:

PreuzmiIzvorni kôd (Text):

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

a na kraju svake funkcije ubaci ovo:

PreuzmiIzvorni kôd (Text):

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

ili ovo
na pocetku:

PreuzmiIzvorni kôd (Text):

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

na kraju:

PreuzmiIzvorni kôd (Text):

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

mozda ti se excel nije smrznuo vec se zaglavio u nekoj petlji. Mozda je naisao na praznu celiju ili nesto sto ne odgovara uvjetima koji su zadani. Ako napise not response ili tako nesto pritisni Ctrl+Break
zaustavice se izvrsavanje koda i stat ce na mjestu gdje se zaglavio. Provjeri celiju koju trenutno obraduje ili red pa ju isto tako provjeri u Listu, sta se u njoj nalazi

mozda bi treblao upisati dio koda koji provjerava dali je celija prazna:
Do While (Cells(lRow, "A") <> "") ili tako nesto da se osiguramo da ne zaglavi.

Mozda nam se cini ponekada da se excel smrznuo no on naporno radi pa zato upotrebljavamo nesto od sljedeceg kod brisanja puno redova kao preventiva od smrzavanja:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
rngCopyRangeVisible.EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Gjoreski (14.01.2019 14:17):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

da zameni ih sa long

White Man (13.01.2019 23:30):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Dim LLoop As Integer
Dim LTestLoop As Integer
Dim Lrows As Integer
Dim Lcol As Integer

Kod ovih? Hvala unapred

Gjoreski (13.01.2019 19:42):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

U modulu zameni gi svi variable koi su integer sa Long
i probaj tako

White Man (13.01.2019 19:30):

Predmet: Re: Kako da obrisem redove sa markiranim celijama

Tako treba da radi kao u Vasem primeru, tu radi odlicno kad otvorim primer. Ali kad prebacim cod kod mene i idem na run, krene lepo, oboji nekoliko redova u crveno i onda zablokira, pobeli i pojavi se not responding. Da li trebam i kod mene da kreiram ono dugme pa preko njega ili je to sto u tablici ima vise od 50 hiljada redova jer se vecinom svaki artikl ponavlja po 50, 60 puta aneki i vise. Sta trebam da uradim? Hvala unapred

Razno. veze

Aktivne teme ...

Vijesti (RSS, ...)

Kontakt

Sva vremena su GMT +01:00. Trenutno vrijeme: 6: 23 pm.

Centar za edukaciju-BiH

Glavni meni

Forumi

Linkovi

iCentar → Racunari i oprema → Softver i operativni sistemi → Ms office → Kako da obrisem redove sa markiranim celijama

Odgovori na temu

Posljednjih 15 postova u ovoj temi

Prijavi se

Izdvojeno