Vymazat rozdíl listů excelu Vyřešeno

[cmuch]

Ahoj,
potřeboval bych vytřídit seznam jmen.
Mám dva listy na jednom jsou abecedně řazena jména a na druhém listě taktéže, ale je jich tam daleko více.
A já bych potřeboval aby tady na tomto listě nějakou fcí nebo makrem zůstali jen ta samá jména jak na tom prvním listě
a ostatní řádky se jmény aby se odstranily.

Děkuji

[Reklama]

[navstevnik]

Pro jednorazove pouziti.
Na druhem listu vloz do pomocneho sloupce vzorec (uprav rozsah prohledavane oblasti):
=KDYŽ(JE.CHYBHODN(SVYHLEDAT(A1;List1!$A$1:$A$3;1;NEPRAVDA));"";"*")
kopiruj podle poctu radku
oba sloupce setrid podle pomocneho sloupce sestupne a odstran radky bez znaku "*" v pomocnem sloupci.

[cmuch]

Aha to bylo lehčí než jsem myslel, já to dělal podobně ale s využitím více slopců.

Dále jsem tady "cmuchal" na fóru a vzorec jsem nějak převed do makra a pro více listů.

Kód: Vybrat vše

Sub duplikace()
  Dim Wsht As Worksheet, Blk As Range, Cll As Range
  ' pro vsechny listy
  For Each Wsht In ThisWorkbook.Worksheets
  ' mimo listy kterých se to netýká
    If Wsht.Name <> "prehled" Then
      ' zjisteni duplicity jmen na dvou listech
      With Wsht
        ' definovat blok vyhledavani
      Set Blk = Wsht.Range("C7:C18")
        ' napsat u shodnych jmen "*" a neshodnych "*N*"
        For Each Cll In Blk.Cells
          With Cll
            .Value = "=IF(ISERROR(VLOOKUP(RC[-2],prehled!R7C1:R18C1,1,FALSE)),""*N*"",""*"")"
          End With
        Next Cll
      End With
    End If
  Next
End Sub


Dále jsem zde našel výmaz řádku podle podmínky viewtopic.php?f=35&t=45216&hilit=%C5%99%C3%A1dek+odstran%C4%9Bn%C3%AD
Ale nedaří se mi to udělat pro jiný/é list/y. Dělá to pořád na akivním listě.
Jediné co se mi podařilo tak odstranit z původního makra okno kde se zadával znak do okna (inputbox) a zadávat tento znak přímo v makru.
Ale aby nevyskakovalo ani první okno kde se zadává oblast a zadávalo se to též pevně v makru se mi nedaří.

Kód: Vybrat vše

Sub OdstranRadek()
  Dim MyArea As Range, Podminka As Variant
  Dim Ofs As Long, Clmn As Range

  Set MyArea = ActiveSheet.UsedRange
  If IsEmpty(MyArea) Then End
  Application.ScreenUpdating = False
  '*********************
  ' odstrani radek, kde bunka v bloku bunek splnuje podminku
  '*********************
On Error Resume Next
  Set Clmn = Application.InputBox("Zadej blok s prazdnymi bunkami, pr: D5:D10", Type:=8)
  If Err.Number <> 0 Then Exit Sub
  If Clmn.Columns.Count > 1 Then MsgBox "Lze zadat pouze 1 sloupec": Exit Sub
  Podminka = "*" 'Znak podle ktereho se mazou radky
  On Error GoTo 0
  Ofs = Clmn.Rows.Count - 1
  Set Clmn = Clmn.Resize(1, 1)
  Do ' odstraneni radku

 If Clmn.Offset(Ofs, 0).Value = Podminka Then Clmn.Offset(Ofs, 0).EntireRow.Delete
    Ofs = Ofs - 1
  Loop While Ofs > -1
  Range("a1").Select
  Application.ScreenUpdating = True
End Sub


Kdo mi poradí, Nebo to odstranění řádku udělá dle sebe.

Kdyžtak v příloze je připravený soubor jak to mám dělané.

[navstevnik]

Je velice chvalihodne, ze ses pusti do samostane prace s VBA.
Zatim ti poradim ja dal v procedure Duplikace, jedno z moznych reseni:
Po dobehnuti smycky For Each Cll In Blk.Cells setrid blok podle pomocneho sloupce (nahraj si makro, uprav) a pak v pomocnem sloupci identifikuj blok bunek s indikatorem na odstraneni, rozsir pres vsechny sloupce a ClearContents.
Az se tim prokouses, tak zkusime jiny postup. Ano?

[cmuch]

To stebou souhlasím. "Ať se trochu potrápí"

Bohužel mi to nejde setřídit podle pomocného sloupce, zkoušel jsem to přes autofiltr kde jsem
1) byl schopen na všech listech setřídit shodná a neshodná jména, ale nebyl jsem schopen nějak smazat ty nechtěné řádky
2) a ještě jsem pak ztroskotal na tom když jsem přidal nějaká data do sloupce B pak se to filtrovalo prvním filtrem a nebyl jsem schopen to filtrovat až tím třetím.

Kód: Vybrat vše

 With Wsht
      With .Range("C6")
      .Value = "duplikace"
      End With
      For Each Cll In Blk.Cells
          With Cll     
            .AutoFilter Field:=1, Criteria1:="~*N~*"
          End With
      Next Cll
      End With

Asi jdu na to nějak špatně

Edit 19:00

Ještě se my podařilo udělat toto, ale to my jde jinak v krokování a jinak v auto.

Kód: Vybrat vše

Sub DelRows()
'
  Dim Wsht As Worksheet, Blk As Range, Cll As Range
  Dim Podminka As Variant, Ofs As Long
' pro vsechny listy
  For Each Wsht In ThisWorkbook.Worksheets
' mimo listy kterých se to netýká
    If Wsht.Name <> "prehled" Then
' zjisteni duplicity jmen na dvou listech pro vymaz
       [color=#FF8000]With Wsht[/color]
' definovat blok vyhledavani
          Set Blk = Wsht.Range("C7:C19")
'smaz radky dle podminky
         For Each Cll In Blk.Cells
           [color=#FF8000]With Cll[/color]
              Podminka = "*" 'Znak podle ktereho se mazou radky
              Ofs = Blk.Rows.Count - 1
              Set Blk = Blk.Resize(1, 1)
                Do ' odstraneni radku'
                If Blk.Offset(Ofs, 0).Value = Podminka Then Blk.Offset(Ofs, 0).EntireRow.Delete
                Ofs = Ofs - 1
                Loop While Ofs > -1
              Range("A1").Select
           End With
         Next Cll
       End With
    End If
  Next
'
End Sub

Jeto sice krkolomné, ale mám to.