Excel- makro na vyhledání a přesunutí
Re: Excel- makro na vyhledání a přesunutí
tady je ukazka jak to ma byt finalne
- Přílohy
-
- ukazka.xlsx
- (10.93 KiB) Staženo 60 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel- makro na vyhledání a přesunutí
Uvadis v popisu cinnosti: "Takto se spojí za podmínky, že sloupce A,B,E a F jsou stejné", pro shodne B, E, F je vsak hodnota v A rozdilna.
Nize uvedena procedura tedy vykona pozadovane mimo shodu v A za predpokladu, ze sheet1 je setriden jak uvadis:
Nize uvedena procedura tedy vykona pozadovane mimo shodu v A za predpokladu, ze sheet1 je setriden jak uvadis:
Kód: Vybrat vše
Option Explicit
Sub FindTransfer()
Dim SBlk As Range, SCll As Range, Tmp As String, OldSCll As String, Separator As String
Dim TBlk As Range, TCllE As Range, TCllK As Range, TOfsR As Long, TOfsC As Integer
' cilove bloky
With Worksheets("sheet2")
Set TBlk = .Range("a1:j1")
Set TCllE = .Range("e1")
Set TCllK = .Range("k1")
End With
TOfsR = -1
With Worksheets("sheet1")
Set SBlk = .Range("f1:f" & .Cells(Rows.Count, 1).End(xlUp).Row) ' zdoj blok
End With
' prohledavat SBlk
OldSCll = vbNullString
For Each SCll In SBlk.Cells
Tmp = SCll.Offset(0, -4).Value & SCll.Offset(0, -1).Value & SCll.Value ' sloupce B, E, F
If Tmp <> OldSCll Then ' nova skupina
OldSCll = Tmp ' ulozit novy stav sloupce B, E, F
' prenest blok Ax:Jx
TOfsR = TOfsR + 1 ' ofset radku na cilovem listu
TOfsC = 0 ' ofset sloupce
Separator = " "
TBlk.Offset(TOfsR, 0).Value = SCll.Resize(1, 10).Offset(0, -5).Value ' Ax:Jx
End If
With TCllE.Offset(TOfsR, 0)
.Value = .Value & Separator & SCll.Offset(0, -5).Value ' pridat do sl E:E hodnotu ze sloupce A:A
End With
' hodnoty ze sloupce A,I, H do K (L, ...) pro prvni a dalsi shodne vyrobky
With SCll
TCllK.Offset(TOfsR, TOfsC).Value = .Offset(0, -5).Value & ":" & .Offset(0, 3).Value & ";" & .Offset(0, 2).Value
End With
Separator = ", "
TOfsC = TOfsC + 1 ' ofset sloupcu
Next SCll
With Worksheets("sheet2")
.Range(.UsedRange.Address).Columns.AutoFit ' upravit sirku sloupcu
End With
Set SBlk = Nothing
Set SCll = Nothing
Set TBlk = Nothing
Set TCllE = Nothing
Set TCllK = Nothing
End Sub
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
-
Přesunutí sms do nového android telefonu
od Petr98 » 21 říj 2023 16:10 » v Mobily, tablety a jiná přenosná zařízení - 4
- 1962
-
od meda2016
Zobrazit poslední příspěvek
21 říj 2023 21:45
-
-
-
WIN 10 přesunutí složek users na jiný disk
od Richard_ZZR » 10 úno 2024 11:30 » v Windows 11, 10, 8... - 3
- 906
-
od petr22
Zobrazit poslední příspěvek
10 úno 2024 13:26
-
-
- 9
- 1234
-
od mmmartin
Zobrazit poslední příspěvek
29 srp 2023 16:47
-
- 16
- 6711
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
- 3
- 2220
-
od Story-Long
Zobrazit poslední příspěvek
14 srp 2023 10:11
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 6 hostů