Question

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

这个过程是这样的：

创建Excel列表。
需要员工手动处理（删除图像，按字母顺序排序等）
该列表将转换为csv文件。
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

SOLUTION：

我使用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个字母的代码，您可以搜索＆＃34;（＆＃34;并剪切字符串

这样的东西会让你获得代码，你可以使用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

至于按字母顺序排列，有两种方法可以想到

将所有值移动到数组中，然后遍历数组并对其进行排序
创建过滤范围，过滤器

第二个选项更容易，对于你正在做的事情，我认为它可能很好。它看起来像这样：

使用如下所示的数据（在单元格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

然后，您可以按单元格或作为范围循环遍历整个工作表单元格 Cell by Cell :(我用这个来解开细胞 - 可能很慢）

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

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

1 个答案: