Public Sub distributeColumns() Dim sTargetSheet As String Dim iNoOfColumnInBlock As Integer Dim iMaxRowsInBlock As Integer Dim lLastRow As Long Dim iNextBlock As Integer Dim rngMove As Range iNoOfColumnInBlock = 3 iMaxRowsInBlock = 5 sTargetSheet = "Sheet1" iNextBlock = 1 With Sheets(sTargetSheet) lLastRow = getItemLocation("*", .Cells) Do While (lLastRow > iMaxRowsInBlock) iNextBlock = iNextBlock + iNoOfColumnInBlock Set rngMove = .Range(.Cells(iMaxRowsInBlock + 1, 1), .Cells(iMaxRowsInBlock * 2, iNoOfColumnInBlock)) rngMove.Copy .Cells(1, iNextBlock).PasteSpecial rngMove.Delete Shift:=xlUp lLastRow = lLastRow - iMaxRowsInBlock Loop End With End Sub Public Function getItemLocation(sLookFor As String, _ rngSearch As Range, _ Optional bFullString As Boolean = True, _ Optional bLastOccurance As Boolean = True, _ Optional bFindRow As Boolean = True) As Long 'find the first/last row/column within a range for a specific string Dim Cell As Range Dim iLookAt As Integer Dim iSearchDir As Integer Dim iSearchOdr As Integer If (bFullString) _ Then iLookAt = xlWhole Else iLookAt = xlPart End If If (bLastOccurance) _ Then iSearchDir = xlPrevious Else iSearchDir = xlNext End If If Not (bFindRow) _ Then iSearchOdr = xlByColumns Else iSearchOdr = xlByRows End If With rngSearch If (bLastOccurance) _ Then Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir) Else Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir) End If End With If Cell Is Nothing Then getItemLocation = 0 ElseIf Not (bFindRow) _ Then getItemLocation = Cell.Column Else getItemLocation = Cell.Row End If Set Cell = Nothing End Function