Copying lists into columns of a table

Question

Edit: I found a potential solution. Changing all of the Dim as Long to Dim as Integer allows the scripts to run smoother. However, there is a potential that the number of rows in some instances will exceed 32767. Is there a way I can put a condition on the first few statements, to use integer only if there are less than 30k rows?

The following script works to take a large dataset from this form in the Worksheet "List"

1 David
Eve
Freya
Sam
Yarra
2 Brian
David
Eva
Harry
Paul
3 Charlie
David
4 Eva
Harry
Paul

And paste it into another worksheet, "Library," like this:

1 2 3 4
David Brian Charlie Eva
Eve David David Harry
Freya Eva Paul
Sam Harry
Yarra Paul

While generating a singleton list of one of each name in the worksheet "List".

The (long) code is pasted below. As I said before, it works fine with shorter lists, but not with larger ones (over 20,000), as it gives me a "Not responding" message where I'm forced to End Task. Is there anything else I can do to fix this? It has been suggested that I add DoEvents, but I'm not sure how I could implement this into the current script. Also, it taking long wouldn't bother me too much if I could have some sort of Progress Bar that updates at each step. Would that work as a DoEvent? All suggestions are welcome.

Sub RunAH_KeyWordLibrary()
Call PrepareKeywords
Call PrepareLibrary
End Sub
Private Sub PrepareKeywords()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Dim Library As Worksheet
Dim List As Worksheet
Set Library = Sheets("Library")
Set List = Sheets("List") 
Dim Rng As Range
Dim i As Long 
Dim lastRow As Long 
i = 1 
lastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).row
 While i <= lastRow 
 Set Rng = Library.Range("A" & i) 
If Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 1 Then 
Rng.Offset(0, 1).Cut 
Rng.Offset(1, 0).Insert Shift:=xlDown 
Rng.Offset(0, 1).Insert Shift:=xlDown 
ElseIf Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 0 Then
i = i + 1
End If 
Wend 
 Application.Calculation = xlAutomatic
 Application.EnableEvents = True
 Application.DisplayStatusBar = True
 Application.EnableEvents = True
End Sub
Private Sub PrepareLibrary()
 Application.ScreenUpdating = False
Dim Library As Worksheet
Set Library = Sheets("Library")
 Dim lastRow As Long
 Dim results As Variant
 Dim resultsIndex As Long
 Dim currentRow As Long
 Dim currentColumn As Integer
 currentColumn = 1
 lastRow = Library.Range("A" & Rows.Count).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
 Library.Cells(1, currentColumn) = results(resultsIndex, 1)
 currentRow = 2
 Else:
 Library.Cells(currentRow, currentColumn) = results(resultsIndex, 1)
 currentRow = currentRow + 1
 End If
 Next
 Sheets("Library").Select
 Cells.Replace What:="~*", Replacement:="", LookAt:=xlPart, SearchOrder _
 :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
 Columns("A:A").Select
 Application.CutCopyMode = False
 Selection.Copy
 Sheets("List").Select
 Range("A1").PasteSpecial 
 Cells.Replace What:="~*", Replacement:="", LookAt:=xlPart, SearchOrder _
 :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 
 Application.Calculation = xlAutomatic
Call Order
Call RemoveNumber
Call MakeUpper
Call RemoveDuplicates
Columns("B:B").Select
Selection.ClearContents 
End Sub
Private Sub Order() 
 Columns("A:A").Select
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Add Key:=Range( _
 "A1:A30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("list").Sort
 .SetRange Range("A1:A30000")
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply 
 End With
End Sub
Private Sub RemoveNumber() 
Dim Rng As Range
Dim i As Long
i = 1
Application.ScreenUpdating = False
Dim lastRow As Long
i = 1
lastRow = List.Range("A1").SpecialCells(xlCellTypeLastCell).row
While i <= lastRow
Set Rng = Range("A" & i)
If IsNumeric(Rng.Value) = True And Len(Rng.Value) > 0 Then
Rng.Delete Shift:=xlUp 
ElseIf IsNumeric(Rng.Value) = False Then
i = i + 1
Else: i = i + 1
End If
Wend
End Sub
Private Sub MakeUpper()
Dim C As Long
Dim List As Worksheet
Set List = Sheets("List")
C = List.Cells(Rows.Count, "A").End(xlUp).row
Range("B1").FormulaR1C1 = "=UPPER(RC[-1])" 
Range("B1").Select
 Selection.AutoFill Destination:=Range("B1:B" & C), Type:=xlFillDefault 
 Columns("B:B").Select
 Selection.Copy
 Range("A1").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Columns("B:B").Select
 Application.CutCopyMode = False
 Selection.Delete Shift:=xlToLeft
End Sub
Private Sub RemoveDuplicates()
Application.EnableEvents = False
Application.Calculation = xlManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim Rng As Range
Dim i As Long
i = 2
Dim lastRow As Long
lastRow = List.Range("A1").SpecialCells(xlCellTypeLastCell).row
While i <= lastRow
Set Rng = List.Range("A" & i)
If Rng = Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
Rng.Delete Shift:=xlUp
ElseIf Rng <> Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
i = i + 1
Else: i = i + 1
End If
Wend
Application.Calculation = xlAutomatic
 Application.EnableEvents = True
 Application.DisplayStatusBar = True
 Application.EnableEvents = True
End Sub

• Mathieu Guindon: Regarding your Integer vs Long concern: you have much bigger performance issues than the size of an integer. Use Long for row numbers, regardless of how many rows you're dealing with.

Answer 1

Your indentation is pretty much random, which makes code quite hard to read and to follow. Use the latest Rubberduck or MZ-Tools VBE add-ins to automatically, properly and consistently indent your code.

Here's your code, after simply clicking Indent Module in Rubberduck (notice Option Explicit):

Option Explicit
Sub RunAH_KeyWordLibrary()
 Call PrepareKeywords
 Call PrepareLibrary
End Sub
Private Sub PrepareKeywords()
 Application.ScreenUpdating = False
 Application.Calculation = xlManual
 Application.DisplayStatusBar = False
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 ActiveSheet.DisplayPageBreaks = False
 Dim Library As Worksheet
 Dim List As Worksheet
 Set Library = Sheets("Library")
 Set List = Sheets("List")
 Dim Rng As Range
 Dim i As Long
 Dim lastRow As Long
 i = 1
 lastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).Row
 While i <= lastRow
 Set Rng = Library.Range("A" & i)
 If Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 1 Then
 Rng.Offset(0, 1).Cut
 Rng.Offset(1, 0).Insert Shift:=xlDown
 Rng.Offset(0, 1).Insert Shift:=xlDown
 ElseIf Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 0 Then
 i = i + 1
 End If
 Wend
 Application.Calculation = xlAutomatic
 Application.EnableEvents = True
 Application.DisplayStatusBar = True
 Application.EnableEvents = True
End Sub
Private Sub PrepareLibrary()
 Application.ScreenUpdating = False
 Dim Library As Worksheet
 Set Library = Sheets("Library")
 Dim lastRow As Long
 Dim results As Variant
 Dim resultsIndex As Long
 Dim currentRow As Long
 Dim currentColumn As Integer
 currentColumn = 1
 lastRow = Library.Range("A" & Rows.Count).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
 Library.Cells(1, currentColumn) = results(resultsIndex, 1)
 currentRow = 2
 Else:
 Library.Cells(currentRow, currentColumn) = results(resultsIndex, 1)
 currentRow = currentRow + 1
 End If
 Next
 Sheets("Library").Select
 Cells.Replace What:="~*", Replacement:="", LookAt:=xlPart, SearchOrder _
 :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
 Columns("A:A").Select
 Application.CutCopyMode = False
 Selection.Copy
 Sheets("List").Select
 Range("A1").PasteSpecial
 Cells.Replace What:="~*", Replacement:="", LookAt:=xlPart, SearchOrder _
 :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
 Application.Calculation = xlAutomatic
 Call Order
 Call RemoveNumber
 Call MakeUpper
 Call RemoveDuplicates
 Columns("B:B").Select
 Selection.ClearContents
End Sub
Private Sub Order()
 Columns("A:A").Select
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Add Key:=Range( _
 "A1:A30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("list").Sort
 .SetRange Range("A1:A30000")
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
End Sub
Private Sub RemoveNumber()
 Dim Rng As Range
 Dim i As Long
 i = 1
 Application.ScreenUpdating = False
 Dim lastRow As Long
 i = 1
 lastRow = List.Range("A1").SpecialCells(xlCellTypeLastCell).Row
 While i <= lastRow
 Set Rng = Range("A" & i)
 If IsNumeric(Rng.Value) = True And Len(Rng.Value) > 0 Then
 Rng.Delete Shift:=xlUp
 ElseIf IsNumeric(Rng.Value) = False Then
 i = i + 1
 Else: i = i + 1
 End If
 Wend
End Sub
Private Sub MakeUpper()
 Dim C As Long
 Dim List As Worksheet
 Set List = Sheets("List")
 C = List.Cells(Rows.Count, "A").End(xlUp).Row
 Range("B1").FormulaR1C1 = "=UPPER(RC[-1])"
 Range("B1").Select
 Selection.AutoFill Destination:=Range("B1:B" & C), Type:=xlFillDefault
 Columns("B:B").Select
 Selection.Copy
 Range("A1").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 Columns("B:B").Select
 Application.CutCopyMode = False
 Selection.Delete Shift:=xlToLeft
End Sub
Private Sub RemoveDuplicates()
 Application.EnableEvents = False
 Application.Calculation = xlManual
 Application.DisplayStatusBar = False
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Dim Rng As Range
 Dim i As Long
 i = 2
 Dim lastRow As Long
 lastRow = List.Range("A1").SpecialCells(xlCellTypeLastCell).Row
 While i <= lastRow
 Set Rng = List.Range("A" & i)
 If Rng = Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
 Rng.Delete Shift:=xlUp
 ElseIf Rng <> Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
 i = i + 1
 Else: i = i + 1
 End If
 Wend
 Application.Calculation = xlAutomatic
 Application.EnableEvents = True
 Application.DisplayStatusBar = True
 Application.EnableEvents = True
End Sub

Your usage of the instruction separator in Else blocks also contributes to make the code hard to read IMO (on top of confusing Rubberduck's indenter, #1508), but anyway the point is that properly indented code is much easier to read... and to debug.

Your Boolean logic could be simplified in this block here:

If Rng = Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
Rng.Delete Shift:=xlUp
ElseIf Rng <> Rng.Offset(1, 0) And IsEmpty(Rng.Value) = False Then
i = i + 1
Else: i = i + 1
End If

To this:

If Rng = Rng.Offset(1, 0) And Not IsEmpty(Rng.Value) Then
 Rng.Delete Shift:=xlUp
Else
 i = i + 1
End If

Avoid turning Boolean values into Boolean expressions (IsEmpty function returns a Boolean value, therefore it is a Boolean expression) - comparing a Boolean to True or False is perfectly redundant.

Also, whenever two or more branches of an If..Else block result in the same code being executed, something isn't right with the logic.

Your usage of line continuations is questionnable, too:

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False

The SkipBlanks parameter's name is on one line, and its value is on another; this defeats the purpose of line continuations, which exist to help improve the readability of long lines.

Selection.PasteSpecial Paste:=xlPasteValues, _
 Operation:=xlNone, _
 SkipBlanks:=False, _
 Transpose:=False

You don't have to put each argument on its own line, but you should avoid splitting an instruction in the middle of a parameter.

---

You're not consistent about explicit vs implicit sheet references either. Sometimes you'll do Library.Range("A1") and other times you'll refer to Range, Cells and Columns without qualifying these function calls with an worksheet object, which makes them implicitly reference whatever worksheet is currently active - and solid, reliable Excel VBA code doesn't rely on Select and Activate (macro recorder code does, and macro recorder code is incredibly frail).

Prime example here:

Private Sub Order()
 Columns("A:A").Select
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("list").Sort.SortFields.Add Key:=Range( _
 "A1:A30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("list").Sort
 .SetRange Range("A1:A30000")
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
End Sub

Could be written as:

Private Sub SortListSheet()
 Dim target As Worksheet
 Set target = ActiveWorkbook.Worksheets("List")
 With target.Sort
 .SortFields.Clear
 .SortFields.Add Key:=target.Range("A1:A30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .SetRange target.Range("A1:A30000")
 .Header = xlGuess
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
End Sub

Notice that the two Range calls are now fully qualified, which prevents a runtime error if the user happens to select another worksheet between the moment execution starts in that procedure, and the moment the .SortFields.Add (or .SetRange) method is called.

Also notice there's no .Select or Selection that needs to get involved at any point. That said, I'm not sure "A1:A30000" is the ideal way of doing what you're trying to do here. What happens the day there's 30,001 rows in column A? Clearly you need a better way to find out what the last row is.

---

The Call keyword doesn't serve any purpose really. This:

Sub RunAH_KeyWordLibrary()
 Call PrepareKeywords
 Call PrepareLibrary
End Sub

Is exactly the same as this:

Sub RunAH_KeyWordLibrary()
 PrepareKeywords
 PrepareLibrary
End Sub

If you consistently name your procedures the way you should, by making their names start with a verb, it shouldn't be "hard" to tell what's a procedure in your code.

---

You repeat this code in several places:

Application.Calculation = some value
Application.EnableEvents = some value
Application.DisplayStatusBar = some value
Application.EnableEvents = some value

Dont' Repeat Yourself. Write it once in a procedure dedicated to this, give it a parameter that determines whether to toggle it on or off, and then call the procedure when you need it, instead of copy-pasting code all over the place.

---

This code relies on active selection:

Sheets("Library").Select
Cells.Replace What:="~*", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("List").Select
Range("A1").PasteSpecial

You already have an object reference for that "Library" sheet - use it! Make another for the destination worksheet, and you can do what the above code does in 3 little statements:

Library.Cells.Replace ...
Library.Columns("A:A").Copy
List.Range("A1").PasteSpecial

---

DoEvents would help improve responsiveness, but is actually going to make the performance worse. Excel going "not responding" doesn't mean the code stopped running; it means Excel isn't repainting itself while it's busy running your macro.

Consider extracting a procedure that turns screen updating on, updates the status bar with some progress message, and then turns screen updating back off; set Application.StatusBar = vbNullString when you're done, to give Excel back its status bar.

First step in improving performance, is to remove Select and Activate, and change all the code that relies on an ActiveSheet, be it implicitly or explicitly. Then you need to minimize the actual worksheet-handling code - the single slowest thing you can do in VBA is manipulate (be it reading or writing) a spreadsheet, so you need to write code that does that as little as possible, and only when needed - for example it's better to copy a whole range in memory as an array, and iterate that array, than iterate the cells in that range on that worksheet. Avoid WorksheetFunctions in VBA code (very often there's an equivalent "native" VBA function for it anyway).

• Raystafarian: If you put all your Application. calls into a separate function, make sure your error handler puts them back!
• user1996971: Thanks a million, Mat. I'll learned a lot from this post. Cheers!
• Mathieu Guindon: @user1996971 sorry I forgot to put a disclaimer... I manage the GitHub repository for the Rubberduck project.

Answer 2

Mat has covered most everything. But,

In RemoveDuplicates and I'll assume List is a codename (or not declared) for a sheet, why not do the same for Library?

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet.

---

If IsNumeric(Rng.Value) = True And Len(Rng.Value) > 0 Then

Doing something like If method = True then is redundant, you can just say If method then

Things like

And IsEmpty(Rng.Value) = False

are better understood by structuring them like this

And Not IsEmpty(Rng.Value) Then

---

I do want to say good job on (declaring and) giving variables meaningful names and following Standard VBA naming conventions.