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

我试图自动化excel修改。

这个过程是这样的：

1. Excel列表被创build。
2. 它需要由员工手动处理（删除图像，按字母顺序sorting等）
3. 该列表被转换成一个CSV文件。
4. CSV被上传和处理。

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

到目前为止，我已经能够争取一些不同的脚本一起中途，但我一直无法得到这两个function的工作。 我已经能够删除顶部的所有膨胀（不在底部），删除空行并删除未使用的列。

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

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

题

我想提取4个字母的代码，并将其replace为全名，因此只有4个字母的代码保留在单元格中。

另外我想列表按字母顺序sorting。 该表的范围每天不同，所以没有固定的单元格。

没有什么别的你需要担心的工作表上。 如有需要，我可以提供更多信息。

如果有人能够帮助我，这将是巨大的。

提前致谢！

编辑：

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

当前脚本之后的表格示例

这是我目前用来删除所有膨胀的脚本。 我相信这不是完美的，但它现在做的工作。

 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 ` 

这是脚本前的表格：

之前

解：

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

我结束了使用这行代码来logging的字母顺序：

 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个字母的代码，您可以search“（”并切断string

像这样的东西会让你的代码，你可以使用registry，但这似乎是矫枉过正

 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. 将所有值移入数组，然后遍历数组并对它们进行sorting
2. 创build一个过滤的范围和filter是

第二个选项是更容易，为你在做什么，我认为这可能是好的。 它看起来像这样：

数据看起来像这样（在单元格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 

我喜欢这个代码find最后一行：

 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 

要删除照片，请使用以下代码： 使用Excel VBA删除照片

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

这似乎是保存csv的工作，如果你想自动化也：

使用VB将excel工作表保存为文件名+工作表名称的CSV文件

我会重新调整所有的行和列，行到他们的默认和列的适合调整：不幸的是，我还没有find一个好的方式来做没有范围string的行，所以我的代码是有点凌乱：

 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