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

• #38968 Fferi50 Topikgazda kezdosql #38967

  Új Válasz 2018-08-24 21:55:56 #38968

  Ú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 kezdosql #38967 üzenetére

  Szia!

  Próbáld ki az alábbi makrót:
  Sub atrako()
Dim ws1 As Worksheet, ws2 As Worksheet, cl As Range, xx As Long, helye As Range, kodja As Range, kod As String
Set ws1 = Sheets("Munka1")
On Error Resume Next
Set ws2 = Sheets("Jelent?s")
If Err = 9 Then
Set ws2 = Sheets.Add(after:=Sheets(Sheets.Count))
ws2.Name = "Jelent?s"
Else
ws2.UsedRange.Clear
End If
On Error GoTo 0
With ws1.Range("A1").CurrentRegion
For Each cl In .Columns(1).Cells
If cl.Row > 1 Then
If Application.WorksheetFunction.CountA(.Rows(cl.Row)) > 1 Then
Set helye = ws2.Columns(1).Find(what:=cl, LookIn:=xlValues, lookat:=xlWhole)
If helye Is Nothing Then
Set helye = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
helye.Value = cl.Value: ws2.Columns.AutoFit
End If
For xx = 1 To .Columns.Count
With cl.Offset(0, xx)
If .Value <> "" Then
kod = Left(.Value, 4)
Set kodja = ws2.Rows(1).Find(what:=kod, LookIn:=xlValues, lookat:=xlWhole)
If kodja Is Nothing Then
Set kodja = ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
kodja.Value = kod
End If
ws2.Cells(helye.Row, kodja.Column).Value = Mid(.Value, 5)
End If
End With
Next
End If
End If
Next
End With
With ws2.UsedRange
.Range("A1") = "A000"
.Sort key1:=Range("A1"), order1:=xlAscending, Orientation:=xlSortRows, Header:=xlYes
.Sort key1:=Range("A1"), order1:=xlAscending, Orientation:=xlSortColumns, Header:=xlYes
.Range("A1").Clear
End With
End Sub

  Az alapadatok a Munka1 munkalapon vannak, ha más a lap neve, írd át légy szíves. Az új elrendezést a Jelentés nevű munkalapon hozza létre. Ha nincs ilyen nevű lap, akkor megkreálja, ha már van akkor törli a tartalmát - tehát többször is lefuttatható.
  A kód szerinti sorbarendezésnél fontos, hogy az egyes oszlopokban használt négyjegyű kódok első betűje minden oszlopban az előzőnél hátrább legyen az ABC-ben (A011,B0XX,C100 stb). A sorbarendezés akkor is megy, ha nem így van, csak akkor nem lesznek az oszlopok kódjai egymás után.
  Kiindulás:
  
  Eredmény:
  
  Üdv.

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