Code to "snake" columns is losing all formatting

youngeli

New Member
Joined
Jun 6, 2015
Messages
4
I have the following code which I found and adapted for my uses. It is designed to take a set number of columns and split them at a set number of rows, and then put the values in those cells that were below the cutoff point to the right of the original columns. I'm using this because I have a long column that I need to automatically display on a single page. The issue is that the formatting I have set to the original column is being lost after the "snaking" occurs. Is there a way to adapt this code further so that it Copy and Pastes rather than does .value = .value?

If that is not possible, how do I go back after the "snaking" and set all the non-integer values in my sheet to have a larger and bold font? Thanks!

Code:
Dim outSheet As Worksheet
Dim inSheet As Worksheet
Dim outCursor As Range
Dim lRow As Long, lastRow As Long
Dim maxRows As Long, repeatAtTop As Boolean
Dim numColumns As Long


    maxRows = 32
    numColumns = 3
    
    
        lastRow = Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row

        Set inSheet = ActiveSheet
        Set outSheet = ActiveSheet ' this is where the output will go
        Set outCursor = outSheet.Range("A1")
        
        
        For lRow = 1 To lastRow
        
            outCursor.Resize(1, numColumns).Value2 = Range(inSheet.Cells(lRow, 1), inSheet.Cells(lRow, numColumns)).Value2 'copy the first two columns to output page
            
            If (lRow - 1) Mod maxRows = 0 And lRow > 1 Then 'every 60 rows, generate new set of columns - so shift outCursor to the right, and back up to the top!
                Set outCursor = outCursor.Offset(0, numColumns).End(xlUp)
            Else
                Set outCursor = outCursor.Offset(1, 0) 'ready for next row of input
            End If
        Next lRow
Range("A33:A10000").Clear
Range("B33:B10000").Clear
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

ukmikeb

Well-known Member
Joined
Jul 10, 2009
Messages
2,757
Hi

Try this for the loop :-
Code:
        For lRow = maxRows + 1 To lastRow Step maxRows
        
             inSheet.Range([A1]).Offset(Int(lRow / maxRows) * maxRows).Resize(maxRows, numColumns).Copy _
                         Destination:=outSheet.Range([A1]).Offset(, Int(lRow / maxRows) * numColumns)

        Next lRow


hth

Btw your code didn't copy row 33!
 
Last edited:
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,147
Messages
5,835,667
Members
430,373
Latest member
swartzfeger

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top