Hierarkia siirtymä-funktiolla

Jos tämä on vain kertaluonteinen tapahtuma, tekisin minä näin. Esimerkissäni minulla on soluissa C1:H1 tasoluvut 1-6 (otsikot) ja tiedosto alkaa 2 riviltä. Kaavat:
C2=JOS(A2=1;B2;"")
D2=JOS(A2=2;B2;"")
E2=JOS(A2=3;B2;"")
F2=JOS(A2=4;B2;"")
G2=JOS(A2=5;B2;"")
H2=JOS(A2=6;B2;"")
Valitse hiirellä solut C2:H2. Tuplaklikkaa solun H2 oikeassa alakulmassa olevaa "pallukkaa". Kaavat kopioituvat alaspäin niin pitkälle kuin A/B sarakkeissa on tietoja.
Kopioidut solut jäävät "valituiksi". Suorita "Kopioi". Valitse solu C2 ja liitä määräten (vain arvot). Poista sarake B. Nyt sinulla on jaoteltu tiedot hierarkisesti sarakkeisiin B:G

moduuliin:

Sub MuokkaaHierarkiapuu()

Dim Taso As Variant
Dim ViimeinenRivi As Integer
Dim i As Integer

ViimeinenRivi = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To ViimeinenRivi

Taso = Cells(i, 1).Value

On Error Resume Next

Select Case Taso

Case 2
Cells(i, 3).Value = Cells(i, 2).Value
Cells(i, 2).ClearContents

Case 3
Cells(i, 4).Value = Cells(i, 2).Value
Cells(i, 2).ClearContents

Case 4
Cells(i, 5).Value = Cells(i, 2).Value
Cells(i, 2).ClearContents

Case 5
Cells(i, 6).Value = Cells(i, 2).Value
Cells(i, 2).ClearContents

Case 6
Cells(i, 7).Value = Cells(i, 2).Value
Cells(i, 2).ClearContents

End Select

Next i

End Sub

moduuliin...

Sub Siirrä()
Dim Alue As Range
For i = 1 To 6
Set Alue = Etsi(i)
Alue.Offset(0, i 1) = Alue.Offset(0, 1)
Next
Columns("B:B").Delete
End Sub

Function Etsi(Hakuehto As Variant) As Range
Dim solu As Range
Dim EkaOsoite As String
With Range("A:A")
Set solu = .Find( _
What:=Hakuehto, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not solu Is Nothing Then
Set Etsi = solu
EkaOsoite = solu.Address
Do
Set Etsi = Union(Etsi, solu)
Set solu = .FindNext(solu)
Loop While Not solu Is Nothing And solu.Address <> EkaOsoite
End If
End With
End Function

Keep EXCELing
@Kunde

Minun versiossa valitaan ensin haluttu sarake tai sarakkeesta arvoalue, jossa on ne luvut kuinka etäälle kyseisestä luvusta oikealla olevan solun arvo siirretään. Esimerkiksi tässä tapauksessa valittaisiin sarake A ja ajettaisiin makro.

Makrossa tarkastetaan ensin että valittuna on vain yhden sarakkeen tietoja. Sitten suodatetaan alueen soluista pelkästään positiiviset arvoltaan yli 1 olevat kokonaisluvut. Kun luku kelpaa, niin oikeanpuoleisen solun sisältöä siirretään luvun verran valintasarakkeesta oikealle päin.

Pastebin-linkki jos s24 rikkoo tuon koodin, vaikkei tietysti sisennyksillä ole VBA:ssa mitään merkitystä: http://pastebin.com/m09YQ5WK

Sub siirra()
If Selection.Columns.Count() = 1 Then
For Each cell In Selection
If Len(cell.Value) > 0 Then
If IsNumeric(cell.Value) = True Then
If Int(cell.Value) = cell.Value And cell.Value > 1 Then
cell.Offset(0, 1).Cut cell.Offset(0, cell.Value)
End If
End If
End If
Next
End If
End Sub