How do I extract data from a cell and order the cells alphabetically?

Question

I'm trying to automate excel modificaions.

The process works like this:

1. The Excel list gets created.
2. It needs to be manually processed by an employee (removing images, sorted alphabetically, etc.)
3. The list gets converted into a csv file.
4. CSV gets uploaded and processed.

Now I would like to automate this process as much as possible. I don't have any experience working with VBA or Excel macros.

So far i've been able to scramble a few different scripts together to get halfway, but I haven't been able to get these two functions working. I've been able to remove all the bloat at the top (not at the bottom yet), remove empty rows and remove unused columns.

I can't post the contents of the sheet itself because of privacy reasons, but the structure of the sheet looks like this:

| Name | Cost |

| Mark Renner (mare) | €200,- |

Question

I want to extract the 4 letter codes and replace them for the full names so only the 4 letter code remains in the cell.

Also I would like the list to be sorted alphabetically. The range of the sheet differs per day so there is no fixed ammount of cells.

There is nothing else on the sheet you need to worry about. I can provide more information if necessary.

It would be tremendous if someone is able to help me with this.

Thanks in advance!

Edit:

Here is some more requested information.

Table example after current script

This is the script I am currently using to remove all the bloat. I'm sure it's not perfect but it does the job for now.

    Sub run()
    Call testvba
    Call DeleteRowWithContents
    Call usedR
    End Sub

    Sub testvba()
    Dim i As Integer
    For i = 1 To 21
    Rows(1).EntireRow.Delete
    Next i

    For i = 1 To 10
    Columns(4).EntireColumn.Delete
    Next i

    Dim shape As Excel.shape
    For Each shape In ActiveSheet.Shapes
    shape.Delete
    Next


    End Sub

    Sub DeleteRowWithContents()
    Last = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "A").Value) = "User" Then
            Cells(i, "A").EntireRow.Delete
        End If
    Next i
    End Sub

    Sub usedR()
    ActiveSheet.UsedRange.Select
    'Deletes the entire row within the selection if the ENTIRE row contains no      data.
    Dim i As Long
    'Turn off calculation and screenupdating to speed up the macro.
    With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    'Work backwards because we are deleting rows.
    For i = Selection.Rows.Count To 1 Step -1
    If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
    Selection.Rows(i).EntireRow.Delete
    End If
    Next i
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    End With
    End Sub `

Here is the table before the script:

Before

SOLUTION:

I used Schalton's code for extracting the 4 letter code.

I ended up using this line of code to alphabetize the records:

    Sub Alpha()
    Dim fromRow As Integer
    Dim toRow As Integer
    fromRow = 1
    toRow = ActiveSheet.UsedRange.Rows.Count
        ActiveSheet.Rows(fromRow & ":" & toRow).Sort Key1:=ActiveSheet.Range("A:A"), _
           Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
           MatchCase:=False, Orientation:=xlTopToBottom
    End Sub

Answer 1

To get the 4 letter code you can search for the "(" and cut the string down

Something like this will get you to the code, you could use regedit but that seems like overkill

Sub ReplaceName()
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = 2 to LastRow 'assumes data starts in row 2 with header in row 1
    if Cells(r,1).value = "" then goto Nextr 'skips blanks
    CurrentString = Cells(r,1).value 'assumes the names are in column 1
    'At this point CurrentString = "Mark Renner (mare)"
    CurrentString = Right(CurrentString,len(CurrentString)-instr(1,CurrentString,"("))
    'At this point CurrentString = "mare)"
    CurrentString = left(CurrentString,instr(1,CurrentString,")")-1)
    'At this point CurrentString = "mare"
    Cells(r,1).value = CurrentString
Nextr:
Next r
End Sub

As far as putting it in alphabetical order, there are two ways that come to mind

1. Move all of the values into an array then iterate through the array and sort them
2. Create a filtered range and filter is

the second option is MUCH easier, and for what you're doing I think it's probably fine. It'll look something like this:

With data that looks like this (in cells A1 to B6):

Name    Cost
Tom     149
Dick    272
Harry   186
Moe     292
Larry   377

I'd do something like this:

Sub SortAlpha()
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Range(Cells(1,1),Cells(LastRow,2)).select 'selects the data and headers
Selection.AutoFilter 'Adds Filter
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear

Range(Cells(1, 1), Cells(LastRow, 1)).Select 'selects name column

'filters alpha
ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Selection _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Range(Cells(1,1),Cells(LastRow,2)).select 'selects the data and headers
Selection.AutoFilter 'Removes Filter
End Sub

That'll Give you this:

Name    Cost
Dick    272
Harry   186
Lary    377
Moe     292
Tom     149

As Far as cleaning the data I usually do a couple of things when I have data tables that are really messy

Start Here:

 1. iterate through the range and remove all merges
 2. unwrap all of the text
 3. delete all pictures
 4. Delete any blank Rows or columns

I like this code for finding the last row:

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

You can modify it to find the last column

LastCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Then you can loop through your whole sheet cell by cell, or as a range Cell by Cell: (I use this to unmerge the cells - can be slow)

For r = 1 to LastRow
    For c = 1 to LastCol
       'Do Stuff
       Cells(r,c).UnMerge 'or Cells(r,c).MergeCells = False
    Next c
Next r

or as a range: I use this for unwrapping the text

Range(Cells(1,1),Cells(LastRow,LastCol)).WrapText = False

To delete the pictures I use this code: Deleting pictures with Excel VBA

Dim shape As Excel.shape
For Each shape In ActiveSheet.Shapes
    shape.Delete
Next

This seems like it would work for saving the csv if you wanted to automate that also:

Saving excel worksheet to CSV files with filename+worksheet name using VB

I'd re-resize all of your rows and columns, rows to their default and columns to the fit: Unfortunately I haven't found a great way to do the rows without a range string so my code is a little messy:

RowRange = "1:" & LastRow
Rows(RowRange).RowHeight = 12.75

Columns are about the same, but worse because they're not numbered

ColStart = Cells(1,1).Address
ColEnd = Cells(1,LastCol).Address
ColStart = left(ColStart,len(ColStart)-1)
ColEnd = left(ColEnd,len(ColEnd)-1)
ColStart = Replace(ColStart,"$","")
ColEnd = Replace(ColEnd,"$","")
ColRange = ColStart & ":" & ColEnd
Columns(ColRange).EntireColumn.AutoFit

you could alternatively just make it significantly large, but where's the fun in that?

Columns("A:ZZ").EntireColumn.AutoFit