Új hozzászólás Aktív témák

• #44097 Fferi50 Topikgazda mulli86 #44095

  Új Válasz 2020-05-21 16:41:23 #44097

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz mulli86 #44095 üzenetére

  Szia!
  Próbáld ki ezt a makrót légy szíves:
  Sub rendezo()
Dim sh1 As Worksheet, sh2 As Worksheet, cl As Range, cl2 As Range, xo As Byte, xu As Long, sh3 As Worksheet, x As Integer, oszlop, drb As Long, ido As Date
Application.ScreenUpdating = False
Set sh1 = Sheets("hiba_kod")
Set sh2 = Munka2 'Most ez az adatok munkalapja Névvel is hivatkozhatsz rá, nekem túl hosszú volt.
Set sh3 = Worksheets.Add(after:=Sheets(1))
sh3.Name = "hiba"
sh3.Cells(1, 1).Value = "Teszt"
xu = 3: xo = sh2.UsedRange.Rows(5).Columns.Count
sh2.UsedRange.Rows(5).Copy Destination:=sh3.Cells(2, 1)
ido = Time()
For Each cl In sh1.UsedRange.Rows(1).Cells ' a hiba-kódok listája
    Application.StatusBar = cl.Value
  oszlop = Application.Match(cl.Value, sh2.Rows(5), 0)'melyik oszlopban van?
    If Not IsError(oszlop) Then
     x = 1 'végig megyünk a hibakódok értékein
       Do
        drb = Application.CountIf(sh2.Columns(oszlop), cl.Offset(x, 0)) 'hány hibás tétel van
          Set cl2 = sh2.Cells(1, oszlop)
          Do While drb > 0
             Set cl2 = sh2.UsedRange.Columns(oszlop).Find(what:=cl.Offset(x, 0).Value, LookIn:=xlValues, Lookat:=xlWhole, after:=cl2)
             If Not cl2 Is Nothing Then
           If sh2.Cells(cl2.Row, xo + 2).Value <> "x" Then 'ha még nincs másolva
              sh2.UsedRange.Rows(cl2.Row).Copy Destination:=sh3.Range("A" & xu) 'másoljuk
              sh2.Cells(cl2.Row, xo + 2).Value = "x" 'és jelöljük a másolást
                xu = xu + 1
             End If
             drb = drb - 1
             End If
          Loop
          x = x + 1
       Loop While cl.Offset(x, 0) <> ""
    End If
    DoEvents
Next
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Futási idő indulás: " & Format(ido, "hh:mm:ss") & " vége:" & Format(Time(), "hh:mm:ss")
End Sub

  Mit csinál?
  A hiba-kod munkalapon levő kódokon megy végig. Megszámolja, hogy az adatok között az adott oszlopban hány hibás tétel fordul elő. Ezeket átmásolja. Mivel egy sorban több hiba is lehet, a duplázás elkerülése érdekében az átmásolt sor végére tesz egy x-et.
  A végén pedig kiírja, mikor indult és mikor fejezte be.
  Ha túl hosszúra nyúlna az idő akkor Ctrl+Break megállítja (ezért van benne a DoEvents sor. Ekkor az éppen aktuális sornál megáll. Meg lehet nézni az eredményt és leállítani vagy folytatni, ahogyan éppen szeretnéd.
  Remélem, nem lesz túl lassú.
  Ha ismételten tesztelsz, ne felejtsd el az x-es oszlopot törölni!
  Üdv.

Új hozzászólás Aktív témák