如何从单元格中提取数据并按字母顺序排列单元格？

Question

我正在尝试自动化 excel 修改。

流程如下：

1. Excel 列表已创建。
2. 需要员工手动处理（删除图片、按字母排序等）
3. 列表被转换为 csv 文件。
4. CSV 被上传和处理。

现在我想尽可能地自动化这个过程。我没有任何使用 VBA 或 Excel 宏的经验。

到目前为止，我已经能够将几个不同的脚本加在一起以达到一半，但我无法让这两个函数正常工作。 我已经能够删除顶部的所有膨胀（不是底部），删除空行并删除未使用的列。

由于隐私原因，我无法发布工作表本身的内容，但工作表的结构如下所示：

| Name | Cost |

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

问题

我想提取 4 个字母代码并将它们替换为全名，因此单元格中只保留 4 个字母代码。

我还希望列表按字母顺序排序。表格的范围每天都不同，因此没有固定数量的单元格。

您无需担心工作表上的其他任何事情。如有需要，我可以提供更多信息。

如果有人能够帮助我解决这个问题，那就太好了。

提前致谢！

编辑：

这里是一些更多要求的信息。

Table example after current script

这是我目前用来消除所有臃肿的脚本。我确信它并不完美，但它现在可以完成工作。

    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 `

这是脚本之前的表格：

Before

解决方案：

我使用 Schalton 的代码来提取 4 个字母的代码。

我最终使用这行代码来按字母顺序排列记录：

    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

要获得 4 个字母的代码，您可以搜索“（”并将字符串剪掉

这样的东西会让你得到代码，你可以使用 regedit 但这似乎有点过头了

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

至于按字母顺序排列，我想到了两种方法

1. 将所有值移动到一个数组中，然后遍历该数组并对它们进行排序
2. 创建过滤范围和过滤器

第二个选项要容易得多，对于您正在做的事情，我认为这可能没问题。它看起来像这样：

使用如下所示的数据（在单元格 A1 到 B6 中）：

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

我会这样做：

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

这会给你这个：

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

就清理数据而言，当我的数据表非常混乱时，我通常会做几件事

从这里开始：

 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

我喜欢这个查找最后一行的代码：

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

你可以修改它以找到最后一列

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

然后您可以逐个单元格或作为一个范围循环遍历整个工作表 逐个单元格：（我用它来取消合并单元格 - 可能很慢）

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

或作为一个范围：我用它来展开文本

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

要删除图片，我使用以下代码： Deleting pictures with Excel VBA

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

如果您还想自动化，这似乎可以保存 csv：

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

我会重新调整所有行和列的大小，将行重新调整为默认值，将列重新调整为合适的大小： 不幸的是，我还没有找到一个很好的方法来处理没有范围字符串的行，所以我的代码有点乱：

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

列大致相同，但更糟糕的是因为它们没有编号

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

你也可以把它做得很大，但这有什么乐趣呢？

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