Listare Itemuri functie de un numar de itemuri din randul adiacent

[H2SO4]

Buna seara,

Va rag sa ma ajutati, sa rezolv o problema, careia nu-I dau de capat.
Itemuri de genul:
col A...col B
K.........T,R,O
T..........K,P
I...........Q,W,R,S
M.........A,G,H
blank
G..........Q,W,E,R,T,Y
T Y.......Z,X

in col D si E as dori sa apara astfel:
col D.........col E
K................T
K................R
K................O
T................K
T................P
I.................Q
I.................W
I.................R
I.................S
...
blank
...
...

si tot asa.

Va rog daca ne puteti ajuta, ne chinuim de zile intregi.

[Catalin B.]

In Power Query, se rezolva in 1 minut, PQ este inclus in uneltele default din excel 2016.
E un simplu Split Column by delimiter, cu optiunea Split into Rows, nu in Columns.
Se pot adauga oricate elemente in tabelul albastru, cu un click dreapta-Refresh in tabelul verde se reproceseaza datele imediat.

[H2SO4]

Multumesc pentru raspuns Catalin,
Conducerea refuza tot ce nu pot sa inteleaga (sper ca nu e vreun sef de-al nostru pe acest site)
Imi cer scuze ca nu am specificat ca dorim rezolvarea cu formule sau cod VBA.

Multumesc.

[IPP]

Buna ziua

Atasat aveti spre testare o propunere folosind macro.
Observatii: am plecat strict de la exemplul din mesajul dvs. Am presupus ca nu va fi nevoie de mai mult de 65535 de randuri (daca da, va trebui editat in cod)

Am folosit urmatorul cod:

Cod: Selectaţi tot

Sub SplitAndWrite()

'IPP - 27.10.2020

Dim myArray() As String
 Dim myItem As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'sterge info veche
Range("D2:E65536").ClearContents

For Each c In Selection
 If c <> "" Then
  myArray = Split(c.Offset(0, 1), ",")
  For Each myItem In myArray
   With Range("D65536").End(xlUp).Offset(1, 0)
   .Value = c.Value
   .Offset(0, 1) = myItem
   End With
  Next myItem
 End If
Next c

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Pentru testare: deschideti fisierul atasat, activati macro/continutul; selectati domeniul de celule cu informatia de pe coloana A (nu e problema daca exista si blank-uri intercalate) pentru care doriti sa se faca acea prelucrare si rulati codul. Rezultatele vor fi afisate pe coloanele D si E (orice informatie existenta acolo fiind inainte stearsa)

IP

[H2SO4]

IPP, multumim.

Codul Dvs nu lasa si rand gol in col D si E daca in col A si B sunt celule goale.
Puteti modifica codul in asa fel:
- daca exista "blank" in col A si B atunci in col D si E sa fie tot "blank"
- daca in col B avem "blank" in col D sa fie trecut itemul din col A
- daca in col A avem "blank" in col E sa fie trecut itemul din col B


col A......col B................col D.......col E
blank......blank............blank.........blank
X...........blank...................X...........blank
blank......M.................blank...........M

PS datele incep cu celula A1, deci am dori ca si rezultatul din col D si e sa inceapa cu randul unu (D1:E1)
Multumesc.

[IPP]

Buna ziua

Testati fisierul atasat.

Am folosit codul:

Cod: Selectaţi tot

Sub SplitAndWrite_2()

'IPP - 27.10.2020

Dim myArray() As String
 Dim myItem As Variant
 
Dim lRow As Long
 lRow = 1
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'sterge info veche
Range("D1:E65536").ClearContents

For Each c In Selection
 If c = "" And c.Offset(0, 1) = "" Then lRow = lRow + 1

 
 If c <> "" And c.Offset(0, 1) = "" Then
  Cells(lRow, 4) = c
  lRow = lRow + 1
 End If
 
 If c = "" And c.Offset(0, 1) <> "" Then
  Cells(lRow, 5) = c.Offset(0, 1)
  lRow = lRow + 1
 End If

 If c <> "" And c.Offset(0, 1) <> "" Then
  myArray = Split(c.Offset(0, 1), ",")
  For Each myItem In myArray
   Cells(lRow, 4) = c
   Cells(lRow, 5) = myItem
   lRow = lRow + 1
  Next myItem
  End If
  
Next c

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

IP

[H2SO4]

IPP,

Aceasta a doua varianta, nu functioneaza.
La aceste date:
K..... T,R,O
T..... K,P
I.......Q,W,R,S
M.... A,G,H
G.....Q,W,E,R,T,Y

T Y Z,X
X
M


returneaza:

K T
K R
K O
T,R,O
T K
T P
K,P
I Q
I W
I R
I S
Q,W,R,S
M A
M G
M H
A,G,H
G Q
G W
G E
G R
G T
G Y
Q,W,E,R,T,Y


T Y Z
T Y X
Z,X
X

M
M

Multumesc.

[Indigo-ONE]

Salut,

Foloseste acest cod:

Cod: Selectaţi tot

Sub Indigo()
  Dim Ki() As String
  Ki = Split(Join(Application.Transpose(Evaluate("IF({1},A1:A100&""|""&SUBSTITUTE(B1:B100,"","","",""&A1:A100&""|""))")), ","), ",")
  Range("D1").Resize(UBound(Ki) + 1) = Application.Transpose(Ki)
  Columns("D").TextToColumns , xlDelimited, , , , , , , 1, "|"
End Sub

Modifica range-ul de date functie de cel real.

[IPP]

Buna ziua

@H2SO4

Nu stiu cum ati testat din moment ce pana acum nu a descarcat nimeni fisierul meu exemplu

in poza atasata vedeti cum am pus informatia si ce mi-a rezultat mie folosind acel cod in fisierul meu exemplu.

Inca nu mi-e clar (mai ales ca nu ati pus niciun fisier) cum anume ati procedat si ati obtinut acele rezultate sau de ce cele obtinute de mine sunt gresite

Daca va referiti la faptul ca acel X din informatia T Y Z,X ar fi trebuit la randul sau "splituit" atunci ar fi bine sa stiti ca nu sunt ghicitor. In exemplele dvs. anterioare nu a existat un astfel de caz astfel incat sa stiu ca trebuie tratat. Ma intreb daca nu or mai fi si altele...

Nu stiu altii, dar eu cand e vorba despre un macro am asteptari legate de documentarea completa a problemei.

IP

PS. Incercati pe viitor sa puneti si un fisier exemplu concludent sub toate aspectele. Daca vi se pare un lucru asa de periculos sa o faceti de la locul de munca, incercati de acasa.

[H2SO4]

Buna dimineata,

@IPP

Te rog nu te superi, nu am descarcat primul fisier, dar am copiat codul si am constatat ca nu lasa randuri goale si datele incep din randul 2.
Imi cer scuze ca nu am specificat in mod expres ca datele incep din randul 1.

La fel am testat si al 2-lea cod si rezultatul l-am pus pe site.
Am sa atasez si fisierul unde am testat.

In legatura cu acel T X acesta era in col A si Z,X erau in col B (literele separate cu virgula sunt in col B).

Multumesc mult pentru ajutor.


@Indigo-ONE

Multumim pentru cod, functioneaza perfect.
Problema este ca nu prea intelegem cum functioneaza. Daca ne puteti ajuta si cu ceva explicatii.