VBAfind全选，然后将所有相邻的单元格向右移
我正在尝试编写一个macros来对工作系统生成的工作簿进行sorting。 我试图从本网站上的其他post一起砍一些代码，但没有成功。
我们的目标是在列A中search包含“IN”或“OUT”的单元格，然后将这些单元格右侧的每个单元向右移动一个单元格。
我有一些代码适用于第一个输出，但它只会准备好第一个输出我知道为什么它不工作，但我不知道如何解决它。
任何帮助将不胜感激，谢谢，
Sub Data_only() ' ' Reworks_Data_only Macro ' ' Keyboard Shortcut: Ctrl+k ' Columns("J:AB").Select Selection.ClearContents Cells.Select Cells.EntireColumn.AutoFit`enter code here` ' ^ Cuts out unused columns and autofits the rest Columns("A:A").Select Selection.Find(What:="in", After:=ActiveCell, LookIn:=xlFormulas, LookAt _ :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:=False).Activate ' ^Searches Column A for "IN" ActiveCell.Offset(, 1).Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' ^Selects the found cell and shift the whole row to the right End Sub 编辑这是我想要改变的文件的模拟，通常会有几百批次和更多的列，但它应该是可行的。 批量模拟
这样的事情是可能的，如果你喜欢使用Findfunction…
Option Explicit Public Sub Data_only() MoveByFind "IN" MoveByFind "OUT" End Sub Public Function MoveByFind(FindString As String) Dim Found As Range Set Found = Columns("A:A").Find(What:=FindString, LookIn:=xlFormulas, LookAt:=xlWhole, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not Found Is Nothing Then Dim firstAddress As String firstAddress = Found.Address 'remember first find for no endless loop Do Found.Offset(0, 1).Insert Shift:=xlToRight 'move cells right Set Found = Columns("A:A").FindNext(After:=Found) 'find next Loop While Not Found Is Nothing And Found.Address <> firstAddress 'loop until end or nothing found End If End Function
你可以用一个简单的循环来完成，而不是使用Find函数：
Dim i as Long, LR as Long LR = Cells(Rows.Count,1).End(xlUp).Row For i = 2 to LR 'Assumes you have a header in row 1 If Cells(i,1).Value = "IN" OR Cells(i,1).Value = "OUT" Then Cells(i,2).Insert Shift:=xlToRight End If Next i
请注意，input和输出区分大小写。
你也可以使用Find函数来做到这一点，不过你可以find所有的，或者使用下一步的find，并且像你在代码中一样使用.insert。
编辑：
假设问题是隐藏字符，可以使用InStr：
Dim i As Long, LR As Long, j As Integer, k As Integer LR = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LR 'Assumes you have a header in row 1 j = InStr(Cells(i, 1).Value, "IN") k = InStr(Cells(i, 1).Value, "OUT") If j > 0 Or k > 0 Then Cells(i, 2).Insert Shift:=xlToRight End If Next i