Pošto si tražio rešenje pomoću VBA moglo bi nešto ovako.
Code:
Option Explicit
Sub Rasporedi()
' Rasporedjuje vrednosti iz kolone A na aktivnom listu
' U tabelu sa cetiri kolone na izabranom odredištu
' P.Jovanvovic za elitesecurity.org
Dim rngSource As Range
Dim rngDest As Range
Dim strNatpis As String
Dim DefRng As String
Dim i As Integer
Dim r As Integer, rstop As Integer
Dim c As Byte
' Izvorni podaci
On Error Resume Next
DefRng = Range("A4", Range("A4").End(xlDown).Address).Address
Set rngSource = Application.InputBox(Prompt:="Selektuj izvorne podatke", Title:="Range Select", Default:=DefRng, Type:=8)
If rngSource Is Nothing Then Exit Sub
If rngSource.Rows.Count Mod 4 > 0 Or _
rngSource.Columns.Count > 1 Then
MsgBox "Nesipravan izvorni opseg"
Exit Sub
End If
' Odredište - samo gornja leva celija!
Set rngDest = Application.InputBox(Prompt:="Selektuj poèetnu æeliju za odrediste", Title:="Range Select", Type:=8)
If rngDest Is Nothing Then
Exit Sub
End If
On Error GoTo 0
Set rngDest = rngDest.Resize(RowSize:=1, ColumnSize:=1) ' Skracivanje izabranog opsega na samo jednu æeliju
rstop = rngSource.Rows.Count / 4 - 1
Set rngSource = rngSource.Cells(1, 1)
For r = 0 To rstop
strNatpis = rngSource.Text
rngDest.Offset(RowOffset:=r, ColumnOffset:=0).Value = strNatpis
If UCase(Trim(strNatpis)) = "UKUPNO" Then
c = 0
Else
c = 1
End If
For i = 1 To 3
rngDest.Offset(RowOffset:=r, ColumnOffset:=i + c).Value = rngSource.Offset(RowOffset:=i).Value
Next i
Set rngSource = rngSource.Offset(RowOffset:=4)
Next r
End Sub
Interestantnije rešenje bilo bi koristeći Offset funkciju i bez VBA koda
Nije to loše Rembrante, samo što ne bi dodao još malo boje?
potreban makro za selekciju i kopiranje vrednosti
