Reformat Table

[peter.nichols]

I have a table with the following format:

CCT Part V1 V2 V3
C47 32000-029 NF
C57 32000-027 NF
C98 32000-004 NF NF
C102 32000-004 NF NF
C118 32000-029 NF NF
C119 32000-029 NF NF
C120 32000-029 NF NF
C121 32000-070 NF NF NF

The number of columns and rows can vary but there will always be a
minimum
of 3 columns
I need to reformat the table to limit the number of rows to say 40 and
move
the data below this row to new columns, ie

CCT Part V1 V2 V3 CCT Part V1 V2 V3 CCT Part V1 V2 V3

is there anyway of doing this in a macro?

I need to do this so that I can output a landscape format BMP file.

Thanks
Pete

 

[Dave O]

Good morning, Pete-
I can help you write a macro, but I still don't follow your question.
Do you mind expanding your example table to include the "before" and
"after", which would show your desired results?

 

[Dave Peterson]

How about something like:

Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim LastRow As Long
Dim FirstRow As Long
Dim iRow As Long
Dim myStep As Long
Dim DestCell As Range

Set CurWks = Worksheets("sheet1")
Set NewWks = Worksheets.Add
Set DestCell = NewWks.Range("a2")

With CurWks
FirstRow = 2
'last row in column A or just 9918??
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
myStep = 39

For iRow = FirstRow To LastRow Step myStep
'copy the headers
.Range("a1").Resize(1, 4).Copy
DestCell.Offset(-1, 0).PasteSpecial Paste:=xlPasteValues

'copy the data
.Cells(iRow, "A").Resize(myStep, 4).Copy
DestCell.PasteSpecial Paste:=xlPasteValues

'get ready for next time
Set DestCell = DestCell.Offset(0, 4)
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit

End Sub

It copies 4 columns all the time, though. (part + 3 v's)

 

[Ken Johnson]

Or do you mean something like this, which requires that the top left
cell of your table, the cell with the CCT heading, be selected before
running the macro?

Public Sub LimitRows()
Dim I As Long
Dim TotalRows As Long
Dim LastRow As Long
Dim MaxRows As Long
Dim NumBlocks As Single
Dim RemainderRows As Long
Dim Retry As VbMsgBoxResult
Dim NewSheet As Worksheet
Dim rngTopLeftCell As Range
Dim vaData As Variant
Dim SheetName As String
SheetName = ActiveSheet.Name
Set rngTopLeftCell = Worksheets(SheetName).Range(ActiveCell.Address)
Dim ACRow As Long, ACColumn As Long
ACRow = rngTopLeftCell.Row
ACColumn = rngTopLeftCell.Column
LastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
TotalRows = WorksheetFunction.CountA( _
Range(ActiveCell, Cells(LastRow, ActiveCell.Column))) - 1
Do
MaxRows = Application.InputBox( _
Prompt:="Input the maximum number of rows in each block of columns", _
Title:="How many rows?", _
Type:=1)
If MaxRows = False Then Exit Sub
NumBlocks = TotalRows / MaxRows
Retry = MsgBox(Prompt:=MaxRows & " rows will result in..." _
& vbNewLine & Int(NumBlocks) _
& " Blocks" _
& IIf(TotalRows Mod MaxRows > 0, " with a part block of " _
& TotalRows Mod MaxRows & " rows", "") & vbNewLine _
& "Try a different number of rows?", _
Buttons:=vbYesNoCancel)
If WorksheetFunction.RoundUp(NumBlocks, 0) * 5 _

Columns.Count Then

MsgBox "Not enough Columns on the sheet!" & vbNewLine _
& "Increase the maximum number of rows per block."
Retry = vbYes
End If
If Retry = vbCancel Then Exit Sub
Loop While Retry = vbYes
Application.ScreenUpdating = False
Set NewSheet = ActiveWorkbook.Worksheets.Add
NewSheet.Name = "New Table"
For I = 1 To WorksheetFunction.RoundUp(NumBlocks, 0)
Range(rngTopLeftCell, rngTopLeftCell.Offset(0, 4)).Copy _
Worksheets("New Table").Cells(1, 1 + (I - 1) * 5)
With Worksheets("New Table")
.Range(.Cells(2, 1 + (I - 1) * 5), .Cells(2 + _
MaxRows - 1, 5 + (I - 1) * 5)).Value = _
Worksheets(SheetName).Range(Worksheets(SheetName).Cells( _
ACRow + 1 + (I - 1) * MaxRows, ACColumn), _
Worksheets(SheetName).Cells(ACRow + I _
* MaxRows, ACColumn + 4)).Value
End With
Next I
End Sub

Ken Johnson

 

[Ken Johnson]

This is a more flexible version that can slice up any table...

Option Explicit
Public Sub Table_Slicer()
Dim I As Long
Dim TotalRows As Long
Dim NumColumns As Long
Dim LastRow As Long
Dim MaxRows As Long
Dim NumBlocks As Single
Dim RemainderRows As Long
Dim Retry As VbMsgBoxResult
Dim rngHeadings As Range
Dim NewSheet As Worksheet
Dim rngTopLeftCell As Range
Dim SheetName As String
Dim lngHeadingRows As Long
Dim lngHeadingColumns As Long
Dim ACRow As Long, ACColumn As Long


On Error GoTo CANCELLED
Set rngHeadings = Application.InputBox( _
prompt:="Starting at the top left table cell, " _
& "select your table headings." _
& vbNewLine _
& "If headings are more than one row deep, " _
& "make sure all heading rows are selected.", _
Title:="Select Table Headings", _
Default:=Selection.Address, _
Type:=8)
On Error GoTo 0

SheetName = ActiveSheet.Name
lngHeadingRows = rngHeadings.Rows.Count
lngHeadingColumns = rngHeadings.Columns.Count
Set rngTopLeftCell = rngHeadings.Cells(1)
ACRow = rngTopLeftCell.Row
ACColumn = rngTopLeftCell.Column
LastRow = Cells(Rows.Count, rngTopLeftCell.Column).End(xlUp).Row
TotalRows = WorksheetFunction.CountA( _
Range(rngTopLeftCell, Cells(LastRow, rngTopLeftCell.Column))) _
- lngHeadingRows

Do
MaxRows = Application.InputBox( _
prompt:="Input the maximum number of rows in each block of columns", _
Title:="How many rows?", _
Type:=1)

If MaxRows = False Then Exit Sub

NumBlocks = TotalRows / MaxRows

Retry = MsgBox(prompt:=MaxRows & " rows will result in..." _
& vbNewLine & Int(NumBlocks) _
& " Blocks" _
& IIf(TotalRows Mod MaxRows > 0, " with a part block of " _
& TotalRows Mod MaxRows & " rows", "") & vbNewLine _
& "Try a different number of rows?", _
Buttons:=vbYesNoCancel + vbDefaultButton2)

If WorksheetFunction.RoundUp(NumBlocks, 0) * lngHeadingColumns _

Columns.Count Then

MsgBox "Not enough Columns on the sheet!" & vbNewLine _
& "Increase the maximum number of rows per block."
Retry = vbYes
End If

If Retry = vbCancel Then Exit Sub

Loop While Retry = vbYes

Application.ScreenUpdating = False
Set NewSheet = ActiveWorkbook.Worksheets.Add
NewSheet.Name = "New Table"
For I = 1 To WorksheetFunction.RoundUp(NumBlocks, 0)
rngHeadings.Copy _
Worksheets("New Table").Cells(1, 1 + (I - 1) * lngHeadingColumns)
With Worksheets("New Table")
.Range(.Cells(1 + lngHeadingRows, _
1 + (I - 1) * lngHeadingColumns), _
.Cells(1 + lngHeadingRows + MaxRows - 1, _
lngHeadingColumns + _
(I - 1) * lngHeadingColumns)).Value = _
Worksheets(SheetName).Range(Worksheets(SheetName).Cells( _
ACRow + lngHeadingRows + (I - 1) * MaxRows, ACColumn), _
Worksheets(SheetName).Cells(ACRow + lngHeadingRows - 1 + I _
* MaxRows, ACColumn + lngHeadingColumns - 1)).Value
End With
Next I
CANCELLED: Exit Sub
End Sub

Just run the macro, no need to select any certain cells before the
macro is run.
The first InputBox asks for the table's heading rows to be selected. If
headings are more than one row deep, you must select all of the heading
rows.
If you would like the blocks of table columns separated from each other
by a blank column, then just select the blank cell(s) immediately to
the right of the table headings (make sure there is no data in that
column).

Ken Johnson