Excel- makro na vyhledání a přesunutí

[Hawkey]

Zdravím,
potřeboval bych poradit s makrem. Mám tabulku na import do eshopu, kde jsou čísla artiklů atd. Ale jeden výrobek, má například několik barev a velikostí, ale i ty jsou označeny vlastním číslem:( potřebuju makro, které když najde ve sloupci A řádky, které mají podobná čísla, lišící se pouze poslední cifrou (např. 19543734,19543736 a 19543739). Pak aby první jemu podobné vzal hodnotu z CA a z CB a vložil do CP toho předka, pokud bude další s podobným číslem lišící se tou poslední cifrou tak aby opět vzal CA a CB a vložil do toho prvního ale ne do CP ale do následující tzn. CS atd... Ty obsahy buněk CA a CB by měli být zřetězeny že mezi nimi bude středník. a vždy když najde takto podobného a převede ty dvě data do nového sloupce původního (předka) tak aby smazal obsah buňky A aktuálního.
Doufám, že to není moc komplikovaně napsané. Pokud to bude nutné, klidně sem hodím soubor s čím to je potřeba pracovat
Předem moc děkuji za jakékoli rady

[Reklama]

[navstevnik]

Cetl jsem vic nez jednou, ale vychazi mi pouze, ze neco se ma nekam presunout a pak neco smazat.
Pripojit prilohu s testovacimi daty, tedy stavem pred presunem a na dalsim listu (muze i na tomtez) rucne vytvorenym vysledkem a s popisem co a jak vztahujicim se ke konkretnim bunkam, protoze "podobne cislo, predek,..." je prilis obecne urceni, bylo potreba hned a ne az na vyzvani.

[navstevnik]

Nize je uvedena procedura (v editoru VBA - Alt+F11 - vlozit do standardniho modulu, pripadne upravit nazvy listu, volat z nabidky Nastroje>Makro>Makra - Alt+F8 - nebo klavesovou zkratkou), snad se mi to z popisu pozadavku podarilo splnit, vysledek je na listu 2:

Kód: Vybrat vše

Option Explicit

Sub FindTranspose()
  Dim SBlk As Range, SCll As Range, SCllVal As Long, SCllLeft As String
  Dim TBlk1 As Range, TBlk2 As Range, TBlk3 As Range, TCll As Range, TOfsR As Long, TOfsC As Integer
  ' cilove bloky
  With Worksheets("sheet2")
    Set TBlk1 = .Range("a1:be1")
    Set TBlk2 = .Range("cy1")
    Set TBlk3 = .Range("dc1")
    Set TCll = .Range("dd1")
  End With
  TOfsR = -1
  With Worksheets("sheet1")
    Set SBlk = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)  ' zdoj blok
  End With
  ' list 1 setridit podle sloupce A:A
  Worksheets("sheet1").Select
  SBlk.Resize(SBlk.Rows.Count, 107).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  ' prohledavat SBlk
  SCllLeft = vbNullString
  For Each SCll In SBlk.Cells
    ' cislo ve sl A:A bez posledni cislice - skupina
    If Left(CStr(SCll.Value), Len(CStr(SCll.Value)) - 1) <> SCllLeft Then
      ' nova skupina
      SCllLeft = Left(CStr(SCll.Value), Len(CStr(SCll.Value)) - 1)
      TOfsR = TOfsR + 1  ' ofset radku na cilovem listu
      ' prenest bloky
      TBlk1.Offset(TOfsR, 0).Value = SCll.Resize(1, 57).Value  ' AAx:BEx
      TBlk2.Offset(TOfsR, 0).Value = SCll.Offset(0, 102).Value  ' CYx
      TBlk3.Offset(TOfsR, 0).Value = SCll.Offset(0, 106).Value  ' DCx
      ' prenest AAx;BEx;CVx -> DDx
      TCll.Offset(TOfsR, 0).Value = SCll.Value & ";" & SCll.Offset(0, 56).Value & ";" & SCll.Offset(0, 99).Value
      TOfsC = 1
    Else
      ' prvek ze skupiny
      ' prenest AAy;BEy;CVy -> DEx (DFx,...)
      TCll.Offset(TOfsR, TOfsC).Value = SCll.Value & ";" & SCll.Offset(0, 56).Value & ";" & SCll.Offset(0, 99).Value
      TOfsC = TOfsC + 1  ' ofset sloupcu
    End If
  Next SCll
  With Worksheets("sheet2")
    .Range(.UsedRange.Address).Columns.AutoFit  ' upravit sirku sloupcu
  End With
  Set SBlk = Nothing
  Set SCll = Nothing
  Set TBlk1 = Nothing
  Set TBlk2 = Nothing
  Set TBlk3 = Nothing
  Set TCll = Nothing
End Sub

Protoze testovaci data obsahuji pouze vyrobky jedne skupiny 2642102Y, otestuj na vetsim poctu skupin

[Hawkey]

Mockrát děkuju, jdu to zkusit. přikládám jinou přílohu, která doufám bude více jasná a hlavně bude více pochopitelná. Hned to zkusím a každopádně hrozně moc děkuji!

[Hawkey]

super! Funguje to! Sice to je tak že to bere ty čísla artiklů a až teď jsem si uvědomil, že záleží na shodnosti těch popisů, ale to vůbec nevadí, takhle je to super. Mockrát děkuju.

[navstevnik]

Mam tomu rozumet tak, ze i kdyz procedura odpovida ukazce, kterou jsi odstranil, je to OK? Ta nova ukazka by totiz vyzadovala napsat uplne jinou proceduru.

[Hawkey]

No to ano. Ale je to vlastně výsledkem to samé. Tahle metoda, je rychlejší a sice můžou nastat situace kdy to nějaký výrobek nesrazí do toho jednoho, ale to nevadí to. takových situacích nastane zanedbatelne mnozstvi. Takhle to jde taky a vyhoda je rychlost oproti tomu druhemu. Jeste jednou diky moc

[Hawkey]

Mohl by mi někdo ještě pomoci? Ten předešlej kód upravit tak, aby se v podmínce vytvoření té skupiny nebralo v potaz hodnota sloupce A bez poslední cifry, ale to, jestli jsou shodné hodnoty (v tomto případě texty) ve sloupci F?

[navstevnik]

Jak jsem uvedl, uvedena procedura byla napsana pro ukazku, kterou jsi z dotazu odstranil. Takze pozadujes upravit tuto proceduru nebo mas na mysli napsat novou proceduru pro ukazku z 8.6.10?

[Hawkey]

Vložím úplně novou ukázku jak to má být, budou asi trochu změny, ale nejdřív odzkouším jednu věc a pak bych sem hodil přímo tu ukázku... A ještě jednou moc díky za pomoc

[Hawkey]

Tak už konečně vím jak to musí být. Mělo by to fungovat stejně jako je makro výše napsané, ale porovnávat by se nemělo podle buněk s číslem artiklu A ale podle toho zda jsou shodné popisy, to znamená buňky ve sloupci F, a podle shodnosti tvořit ty skupiny. A další změna je v tom, že kromě přesunu těch hodnot ze sloupce A by se měli zkopírovat také za text ve sloupci E a oddělit čárkou.

[navstevnik]

Predmetna procedura byla napsana pro v mezicase odstraneny soubor ukazka.xlsx. V ukazce z 8.6. jsou vsak zaznamy slucovany do jinych sloupcu.
Takze se jednoznacne rozhodni, co potrebujes: upravit proceduru pro puvodni ukazku nebo napsat novou proceduru pro novou ukazku.