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

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).

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.