patternMinor
Re-arranging a list into columns
Viewed 0 times
arranginglistintocolumns
Problem
In short, what this script aims to do is take the following data:
And re-arrange like this:
The code I have is as follows:
Essentially, this runs through Column A one at time, copying each cell across individually, pasting into a new row whenever it comes across a number. It works well on small databases, but when expanding out to over 20,000 rows of data, I get a "not enough resources" message. Willing to attempt an entirely different approach if it seems possible. I'm new to VBA, so that may explain why this code is quite inefficient.
1
Alpha
Beta
Delta
2
Beta
Echo
Foxtrot
Kilo
3
Alpha
Kilo
4
Beta
Echo
Kilo
ZuluAnd re-arrange like this:
1 2 3 4
Alpha Beta Alpha Beta
Beta Echo Kilo Echo
Delta Foxtrot Kilo
Kilo ZuluThe code I have is as follows:
Private Sub PrepareLibrary()
Application.ScreenUpdating = False
Dim Rng As Range
Dim i As Long
Dim n As Range
Dim x As Long
Dim Library As Worksheet
Dim LastRow As Long
Set Library = Sheets("Library")
i = 1
x = 0
LastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).row
Do While i <= LastRow
Set Rng = Library.Range("A" & i)
Set n = Library.Range("A1")
If IsNumeric(Rng) = True Then
x = x + 1
Rng.Copy
n.Offset(0, x).Insert Shift:=xlDown
i = i + 1
ElseIf IsNumeric(Rng) = False Then
Rng.Copy
n.Offset(1, x).Insert Shift:=xlDown
i = i + 1
ElseIf Application.WorksheetFunction.CountA(Rng) = 0 Then
i = i + 1
End If
Loop
End SubEssentially, this runs through Column A one at time, copying each cell across individually, pasting into a new row whenever it comes across a number. It works well on small databases, but when expanding out to over 20,000 rows of data, I get a "not enough resources" message. Willing to attempt an entirely different approach if it seems possible. I'm new to VBA, so that may explain why this code is quite inefficient.
Solution
Your naming tells me nothing and doesn't follow Standard VBA naming conventions.
With
A good way to speed up your macro is to use
Additionally, you're doing everything on the sheet, which is slow by nature. Even just reading into an array should be quicker -
That's not a very good example of using the array to the maximum benefit, but it's something.
Dim i - this is a counter? why not rowNumber
Dim n - this is also a counter? why not labelNumber
Dim x - is this a counter? why not nextRowNumber
Dim Library should be library
Dim LastRow should be lastRowWith
library in fact Worksheets have a CodeName property - View Properties window (F4) and the (Name) field can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.A good way to speed up your macro is to use
Application.Screenupdating = False and Application.Calculation = xlManual and Application.EnableEvents = False. Just be sure to return them to True and xlAutomatic and True before exiting the sub.Additionally, you're doing everything on the sheet, which is slow by nature. Even just reading into an array should be quicker -
Option Explicit
Private Sub PrepareLibrary()
Application.Screenupdating = False
Dim lastRow As Long
Dim results As Variant
Dim resultsIndex As Long
Dim currentRow As Long
Dim currentColumn As Long
currentColumn = 0
lastRow = Library.Cells(Rows.Count, "A").End(xlUp).Row
ReDim results(1 To lastRow)
results = Library.Range("A1:A" & lastRow).Value
For resultsIndex = 1 To lastRow
If IsNumeric(results(resultsIndex, 1)) Then
currentColumn = currentColumn + 1
Sheets("Sheet2").Cells(1, currentColumn) = results(resultsIndex, 1)
currentRow = 2
Else:
Sheet2.Cells(currentRow, currentColumn) = results(resultsIndex, 1)
currentRow = currentRow + 1
End If
Next
Application.Screenupdating = True
End SubThat's not a very good example of using the array to the maximum benefit, but it's something.
Code Snippets
Dim i - this is a counter? why not rowNumber
Dim n - this is also a counter? why not labelNumber
Dim x - is this a counter? why not nextRowNumber
Dim Library should be library
Dim LastRow should be lastRowOption Explicit
Private Sub PrepareLibrary()
Application.Screenupdating = False
Dim lastRow As Long
Dim results As Variant
Dim resultsIndex As Long
Dim currentRow As Long
Dim currentColumn As Long
currentColumn = 0
lastRow = Library.Cells(Rows.Count, "A").End(xlUp).Row
ReDim results(1 To lastRow)
results = Library.Range("A1:A" & lastRow).Value
For resultsIndex = 1 To lastRow
If IsNumeric(results(resultsIndex, 1)) Then
currentColumn = currentColumn + 1
Sheets("Sheet2").Cells(1, currentColumn) = results(resultsIndex, 1)
currentRow = 2
Else:
Sheet2.Cells(currentRow, currentColumn) = results(resultsIndex, 1)
currentRow = currentRow + 1
End If
Next
Application.Screenupdating = True
End SubContext
StackExchange Code Review Q#127575, answer score: 2
Revisions (0)
No revisions yet.