variablessearch单元格VBA
我有以下专栏（1）：
1 15 150 1500000 06700 07290 07500 2 22 220 2200000 00900 这将需要成为2列
1 15 150 1500000 06700 1500000 07290 1500000 07500 2 22 220 2200000 00900
我最初的想法：
- 创build额外的列。
- 循环遍历行，当发现长度为7位的数字时，将variables的单元格和值注册到variables中。
- 将它下面的值移到B列，直到值的长度小于5
- 从保存在variables中的单元格开始，将值从variables复制到A列，直到A列不再为空
- 经过上述过程，循环行并删除A长度为7，B为空。
因为我对VBA不熟悉，所以在尝试之前，我想validation一下上面这套规则是否可以做到我打算做的事情，如果在技术上可行的话，VBAmacros和其他macros可能会导致意想不到的行为。
这个代码将不得不每个月在一个新的大型Excel文件上运行。
无论您的5位（c / w /前导零）数字是单元格格式为00000真实数字还是具有Range.PrefixCharacter属性的文本类似数字， Range.Text属性应该能够确定它们从显示的文本修剪长度。
以下代码遵循逻辑步骤进行一些修改; 最明显的就是它从A列的底部走到顶部。 这是为了避免跳过已被删除的行。
Sub bringOver() Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant 'put the cursor anywhere in here and start tapping F8 'it will help if you can also see the worksheet with your 'sample data ReDim vVAL5s(0) 'preset some space for the first value With Worksheets("Sheet1") '<~~ set this worksheet reference properly! 'ensure a blank column B .Columns(2).Insert 'work from the bottom to the top when deleting rows 'or you risk skipping a row For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'determine the length of the trimmed displayed length 'and act accordingly Select Case Len(Trim(.Cells(rw, 1).Text)) Case Is < 5 'do nothing Case 5 'it's one to be transferred; collect it vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text 'make room for the next ReDim Preserve vVAL5s(UBound(vVAL5s) + 1) Case 7 'only process the transfer if there is something to transfer If CBool(UBound(vVAL5s)) Then 'the array was built from the bottom to the top 'so reverse the order in the array ReDim vREV5s(UBound(vVAL5s) - 1) For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1 vREV5s(UBound(vREV5s) - v) = vVAL5s(v) Next v 'working With Cells is like selecting htem but without selecting them 'want to work With a group of cells tall enough for all the collected values With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1) 'move over to column B and put the values in .Offset(0, 1) = Application.Transpose(vREV5s) 'make sure they show leading zeroes .Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]@" 'if there was more than 1 moved over, FillDown the 7-wide value If CBool(UBound(vREV5s)) Then .FillDown 'delete the last row .Cells(.Rows.Count + 1, 1).EntireRow.Delete End With 'reset the array for the next first value ReDim vVAL5s(0) End If Case Else 'do nothing End Select 'move to the next row up and continue Next rw 'covert the formatted numbers to text Call makeText(.Columns(2)) End With End Sub Sub makeText(rng As Range) Dim tCell As Range For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers) tCell.Value = Format(tCell.Value2, "\'00000;@") Next tCell End Sub
就在退出主程序之前，使用列B作为一个单元格范围调用短助手sub。 这将遍历B列中的所有数字，并将数字转换为前导零的文本。
如代码注释中所述，设置自己以便您可以看到代码表以及工作表的一部分，然后开始点击F8以逐步执行代码。 我试图添加一个运行注释的forms，留下许多代码行上面的注释。
在写完逻辑之后，Jeeped的input结束了：
- 强制将列A转换为Text
- 创build额外的列。
- 获取数据的行数
- 循环1：如果列A的单元格长度为5，请将单元格移动到B列
- 循环2：如果列A的单元长度是7，我们将该值复制到variables。
- 循环2：如果列A的单元长度为0，我们将variables粘贴到单元格中
- 经过上述过程，循环行并删除A长度为7，B为空。 （性能反向循环）
下面发布的代码的所有input是比欢迎。 我对每一种可能的优化都是开放的。
Sub FixCols() 'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim Range("A:A").NumberFormat = "@" Dim Cell As Range For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells x = x + 1 Cell = Trim(Cell) Cell.Value = WorksheetFunction.Trim(Cell.Value) Next 'Now insert empty column as B Columns("B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'Determine rows with values for loop With ActiveSheet LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'Loops to move around the data Dim i As Long Dim CellValue As Long For i = 1 To LastRow 'move items to column B If Len(Range("A" & i).Value) = 5 Then Range("A" & i).Select Selection.Cut Range("B" & i).Select ActiveSheet.Paste End If Next i For i = 1 To LastRow 'if the row is a reknr we copy the value If Len(Range("A" & i).Value) = 7 Then CellValue = Range("A" & i).Value End If 'Paste the reknr to the rows with item If Len(Range("A" & i).Value) = 0 Then Range("A" & i).Value = CellValue End If Next i 'Reverse loop (performance) to check for rows to delete (reknr without item) i = LastRow Do If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then Rows(i).Delete End If i = i - 1 Loop While Not i < 1 End Sub