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
