Question

我正在尝试编写一个宏，它将对工作系统生成的工作簿进行排序。我试图从本网站上的其他帖子中拼凑出一些代码，但没有成功。

目标是在A列中搜索包含“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

修改这是我希望改变的文件的模拟，通常会有几百个批次和更多的列，但它应该是可行的。 batches mock up

Answer 1

如果您想使用Find函数......

，可能会出现类似情况

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

Answer 2

您可以使用简单循环执行此操作，而不是使用“查找”功能：

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

请注意，In和Out区分大小写。

您也可以使用Find函数执行此操作，但您可以找到所有函数，或者使用find next，并在代码中使用.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

VBA找到select all然后将所有相邻单元格向右移动

2 个答案: