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
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

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:

Watch MrExcel Video

Forum statistics

Threads
1,122,548
Messages
5,596,787
Members
414,102
Latest member
8885001133

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