I think you should consider transferring this application to Access or other database. The rest of this answer assumes that this is not possible at this time.
The approach you are considering has a slow loop:
With Worksheets("Input")
Cut
End With
With Worksheets("Output")
Paste
End With
I would :
- upload the entire UsedRange from Worksheet Input to Array1
- analyse Array1 to determine the size of Worksheet Output
- create an appropriately sized Array2
- move data from Array1 to Array2
- download Array2 to worksheet Output.
If you need example code, I am happy to provide some. I could code for your example sheet but some characteristics of the real worksheets would give you more useful code for little extra effort on my part.
Part 2
You say "The actual file is much more complex than this - but I created this schematic to describe the essence of the problem."
I have assumed:
- The columns not linked to a particular year are on the left.
- For each year there are the same columns in the same sequence.
- All header cells have the same foreground and background colours and the same single bold state.
- Horizontal alignment of data cells is the default for the data type.
- There need not be data for every year for every customer/product combination.
- The number formats for the first data row may be applied to all rows.
- The value in row 1 of the first column of a block of year columns may be used for the year column in the output.
I created worksheet Input and created the 20 data rows. I duplicated data rows 3 to 22 down to create 5,000 data rows. I assume this is a fair representation of your data:
The output from the macro is in worksheet Output:
This is what I believe you seek. I have rearranged the data as specified. I have copied the format of the header rows, the column widths and the number formats across. If you have formulae in the input they will be values in the output.
For 5,000 rows the macro takes about .1 seconds to copy the data and about .05 seconds to apply the formatting.
In the code I have included comments to say what I am doing and why I am doing it but there are not many comments explaining the VBA statements. For example the first statement is Option Explicit. It is easy to look this up in VB Help or you can search the internet for "Excel VBA Option Explicit". Come back with questions if necessary.
Hope this helps.
Option Explicit
Sub Reformat()
Dim CellHeaderColourBack As Long
Dim CellHeaderColourFore As Long
Dim CellHeaderBold As Boolean
Dim CellInValue() As Variant
Dim CellOutHeaderHAlign() As Long
Dim CellOutNumberFormat() As String
Dim CellOutValue() As Variant
Dim ColInCrnt As Long
Dim ColInCrnt2 As Long
Dim ColInMax As Long
Dim ColOutCrnt As Long
Dim ColOutMax As Long
Dim ColWidth() As Single
Dim NumRowsData As Long
Dim RowInCrnt As Long
Dim RowInMax As Long
Dim RowOutCrnt As Long
Dim RowOutMax As Long
Dim TimeStart As Single
' I use constants to define values that might change. For example, you have
' two header rows so the first data row is 3.
' "For RowCrnt = RowDataFirst to RowMax" instead of
' "For RowCrnt = 3 to RowMax"
' makes the code easier to understand and makes it easy to update the code
' if you add another header row.
Const RowDataFirst As Long = 3 ' First data row
Const NumNonYearCols As Long = 4 ' Number of columns not linked to a year
Const NumColsPerYear As Long = 2 ' Number of columns per year
TimeStart = Timer ' Seconds since midnight
With Worksheets("Input")
' There are several ways of identifying the last column and the last row.
' None work in every situation. I think this method should be satisfactory
' for your worksheet although there is a warning later about ColMax.
ColInMax = .Cells.SpecialCells(xlCellTypeLastCell).Column
RowInMax = .Cells.SpecialCells(xlCellTypeLastCell).Row
' Debug.Print output to the Immediate Window. I have left diagnostic
' outputs within the code. Delete once you have adapted the code to
' your requirements.
Debug.Print "ColInMax=" & ColInMax & " RowInMax=" & RowInMax
' I never did much programming in C++ or Java but I never used a language
' that did not have an Assert statement of some kind.
' A key assumption of the code is that the the number of columns is of the
' form: NumNonYearCols + NunYears * NumColsPerYear.
' The interpreter will stop on this statement if this assumption is untrue.
' If the interpreter does stop even though you think the assumption is true,
' you will probably have a stray value or formatted cell to the right of the
' main data table. Try deleting columns to the right of the data table.
' Alternatively, set ColInMax = NumNonYearCols + NumYears * NumColsPerYear
' so the extract ignores anything outside the data table.
Debug.Assert (ColInMax - NumNonYearCols) Mod NumColsPerYear = 0
' Load all values within the worksheet to the array CellValue.
CellInValue = .Range(.Cells(1, 1), .Cells(RowInMax, ColInMax)).Value
' CellInValue will now be a two dimensional array. Dimension 1 will be for
' rows and dimension 2 will be for columns. This is not conventional for
' arrays but matches the VBA for accessing cells.
' The lower bound for both dimensions will be 1.
' Record the formatting of cell A1 so this can be applied to all header
' cells in worksheet Output. If the formatting is more complicated than
' this, it will probably be easier to copy and paste the header rows from
' the input to the output worksheet.
With .Cells(1, 1)
CellHeaderColourBack = .Interior.Color
CellHeaderColourFore = .Font.Color
' Warning the bold state of a cell will be non-boolean if
' some characters are bold and some are not.
CellHeaderBold = .Font.Bold
End With
' Calculate number of columns in worksheet Output
ColOutMax = NumNonYearCols + 1 + NumColsPerYear
' Record column widths and number formats for first data row and horizontal
' alignment for last header row.
' The column widths will be applied to the relevant output columns
' The number formats will be applied to data cells in the relevant
' output column.
' The horizontal alignments will be applied to header cells in the
' relevant output column.
ReDim ColWidth(1 To ColOutMax)
ReDim CellOutNumberFormat(1 To ColOutMax)
ReDim CellOutHeaderHAlign(1 To ColOutMax)
ColOutCrnt = 1
' Non-year-linked columns
For ColInCrnt = 1 To NumNonYearCols
ColWidth(ColOutCrnt) = .Columns(ColInCrnt).ColumnWidth
CellOutNumberFormat(ColOutCrnt) = _
.Cells(RowDataFirst, ColInCrnt).NumberFormat
CellOutHeaderHAlign(ColOutCrnt) = _
.Cells(RowDataFirst - 1, ColInCrnt).HorizontalAlignment
ColOutCrnt = ColOutCrnt + 1
Next
' Year column
ColWidth(ColOutCrnt) = 5
CellOutNumberFormat(ColOutCrnt) = "General"
CellOutHeaderHAlign(ColOutCrnt) = xlRight
ColOutCrnt = ColOutCrnt + 1
' Year-linked columns
For ColInCrnt = NumNonYearCols + 1 To NumNonYearCols + NumColsPerYear
ColWidth(ColOutCrnt) = .Columns(ColInCrnt).ColumnWidth
CellOutNumberFormat(ColOutCrnt) = _
.Cells(RowDataFirst, ColInCrnt).NumberFormat
CellOutHeaderHAlign(ColOutCrnt) = _
.Cells(RowDataFirst - 1, ColInCrnt).HorizontalAlignment
ColOutCrnt = ColOutCrnt + 1
Next
End With
' I have now extracted everything I want from worksheet Input.
' Worksheet Output will have 1 data row per value in a Quantity column.
' Count these values.
NumRowsData = 0
For RowInCrnt = RowDataFirst To RowInMax
For ColInCrnt = NumNonYearCols + 1 To ColInMax Step NumColsPerYear
If CellInValue(RowInCrnt, ColInCrnt) <> "" Then
NumRowsData = NumRowsData + 1
End If
Next
Next
Debug.Print NumRowsData
' Size CellOutValue so it can hold all the data for Worksheet Output.
' ColOutMax = NumNonYearCols + 1 + NumColsPerYear ' Calculated earlier
RowOutMax = RowDataFirst - 1 + NumRowsData
ReDim CellOutValue(1 To RowOutMax, 1 To ColOutMax)
' Build new header rows.
' Copy header cells for non-year-linked columns
RowOutCrnt = 1
For RowInCrnt = 1 To RowDataFirst - 1
ColOutCrnt = 1
For ColInCrnt = 1 To NumNonYearCols
CellOutValue(RowOutCrnt, ColOutCrnt) = CellInValue(RowInCrnt, ColInCrnt)
ColOutCrnt = ColOutCrnt + 1
Next
RowOutCrnt = RowOutCrnt + 1
Next
' Create header for new column
CellOutValue(RowDataFirst - 1, ColOutCrnt) = "Year"
' Copy one set of year-linked column header cells
RowOutCrnt = 2 ' Row 1 holds year numbers
For RowInCrnt = 2 To RowDataFirst - 1
ColOutCrnt = NumNonYearCols + 2
For ColInCrnt = NumNonYearCols + 1 To NumNonYearCols + NumColsPerYear
CellOutValue(RowOutCrnt, ColOutCrnt) = _
CellInValue(RowInCrnt, ColInCrnt)
ColOutCrnt = ColOutCrnt + 1
Next
RowOutCrnt = RowOutCrnt + 1
Next
' Copy data
RowOutCrnt = RowDataFirst
For RowInCrnt = RowDataFirst To RowInMax
For ColInCrnt = NumNonYearCols + 1 To ColInMax Step NumColsPerYear
' This for-loop tracks the first column of each block of year columns
If CellInValue(RowInCrnt, ColInCrnt) <> "" Then
' There is data for this year for this customer/product
' Copy non-year-linked data
ColOutCrnt = 1
For ColInCrnt2 = 1 To NumNonYearCols
CellOutValue(RowOutCrnt, ColOutCrnt) = _
CellInValue(RowInCrnt, ColInCrnt2)
ColOutCrnt = ColOutCrnt + 1
Next
' Copy year
CellOutValue(RowOutCrnt, ColOutCrnt) = CellInValue(1, ColInCrnt)
ColOutCrnt = ColOutCrnt + 1
' Copy year-linked data
For ColInCrnt2 = ColInCrnt To ColInCrnt + NumColsPerYear - 1
CellOutValue(RowOutCrnt, ColOutCrnt) = _
CellInValue(RowInCrnt, ColInCrnt2)
ColOutCrnt = ColOutCrnt + 1
Next
RowOutCrnt = RowOutCrnt + 1
End If
Next
Next
With Worksheets("Output")
' Delete any existing value
.Cells.EntireRow.Delete
' Download contents of CellOutValue
.Range(.Cells(1, 1), .Cells(RowOutMax, ColOutMax)).Value = CellOutValue
'Set formatting. Selection formats from the input worksheet were saved at
' the beginning. Applying these formats to the output worksheet is not
' necessary but makes the process a little smoother.
For RowOutCrnt = 1 To RowDataFirst - 1
For ColOutCrnt = 1 To ColOutMax
With .Cells(RowOutCrnt, ColOutCrnt)
.Interior.Color = CellHeaderColourBack
.Font.Color = CellHeaderColourFore
.Font.Bold = CellHeaderBold
.HorizontalAlignment = CellOutHeaderHAlign(ColOutCrnt)
End With
Next
Next
For ColOutCrnt = 1 To ColOutMax
.Columns(ColOutCrnt).ColumnWidth = ColWidth(ColOutCrnt)
.Range(.Cells(RowDataFirst, ColOutCrnt), _
.Cells(RowOutMax, ColOutCrnt)).NumberFormat _
= CellOutNumberFormat(ColOutCrnt)
Next
End With
Debug.Print "Duration " & Timer - TimeStart
End Sub
