Question

我正在尝试添加VBA代码，它将组合更完整的单元格。例如，包含单词“Class”的每个单元格本身都很好。但是，如果单元格包含“类”，则它还应包含“和”。一些包含“类”的单元格不包含“和”。包含相关“和”的单元格在下面是一行或两行，但它是下一个单元格。

GE，GH，GK，GL，GN，GP，
类
GQ和IG

Class LD

Class LP

H，HB，HC，HD，HE，HG，

HI，HJ，HK，HL，HN，HP和HQ

E，EA，EB，EC，ED，EG和EI等级

具有“E类，EA类，EB类，EC类，ED类，EG类和EI类”的行本身很好，因为“类”和“和”在同一个单元格中。包含“Class GE ......”及其下方单元格的单元格“GQ和IG”现在需要成为一个单元格。

我到目前为止的代码是：

Dim cell As Range
Dim ContainWord, ContainWord2, ContainWord3, ContainWord4 As String
Dim lngTotRows As Integer

lngTotRows = Range("A" & Rows.Count).End(xlUp).Row

Set rng = Range("A1:BB" & lngTotRows)
ContainWord = "Class"
ContainWord2 = "Classes"
ContainWord3 = "and"
ContainWord4 = ","

'Delete all cells without the ContainWords
For Each cell In rng.Cells

If cell.Find(ContainWord) Is Nothing And cell.Find(ContainWord2) Is Nothing 
  And cell.Find(ContainWord3) Is Nothing And cell.Find(ContainWord4) Is 
Nothing Then cell.Clear
Next cell

    Range("A1").Select 

'Combine cells which have "classes" but not "and" with the subsequent cells   
 which contain "and"
 For Each cell In rng.Cells
 If InStr(cell, ContainWord2) > 0 And InStr(cell, ContainWord3) = 0 Then

我的第一个任务是删除那些不包含含有单词的内容，效果很好。这是我遇到困难的下一部分。我已经查看了一堆关于ifs和containswords以及和InStr结合的其他线程，但是在“Then”之后无法弄清楚要做什么。任何帮助将不胜感激。

Answer 1

vba中的连接可以替换为＆＃34;＆amp;＆＃34;和字符串

    dim string1,string2 as string
    dim nextCell as range

    For Each cell In rng.Cells
      string1= cell.text
      if instr(string1, containword2) >0 and not instr(string1, containword3) >0 then
          set nextcell = activeworksheet.usedrange.find(what:=containword3, after:=cell.address, _
                     lookat:=xlpart, lookinxlformulas, _
                     search order:= xlbyrows, searchdirection:=xlnext, _
                     matchcase:=false)
          string2= nextcell.text
          cell.text= string1 & " " & string2
          nextcell.clear 
      end if

    Next cell

代码未经测试，想法是找到包含单词＆＃34;和＆＃34;的下一个单元格。并将其与当前单元格连接起来。但是，有一种情况下，下一个单元格可能包含＆＃34;类和＃34;和＆＃34;和＆＃34;，上面的代码不起作用。不确定您的数据中是否包含此案例。如果你这样做，请告诉我。

Answer 2

我在您的数据中看到了不同的逻辑，因此采用了不同的方法：如果单词＆＃34; class＆＃34;如果不是单元格的内容，则必须将其附加到上一个内容中。我也不建议删除数据（他们花了很多时间来积累，大声笑:)。相反，我的代码下面写了一个新列表。我将此列表放在同一张纸上，但您可以在任何地方创建它。

在您尝试使用该代码之前，请在代码顶部设置合适的TargetColumn。我还建议您将With Activesheet替换为With Worksheets("My List of Classes")之类的内容，这会使代码更容易发生意外。

Private Sub MergeClassList()
    ' 08 Jan 2018

    Const TargetColumn As Long = 10              ' column to write result to

    Dim Itm As String, Out As String
    Dim Sp() As String                          ' helper to insert "and"
    Dim Rt As Long                              ' Target row
    Dim Rl As Long                              ' last used row
    Dim R As Long

    Application.ScreenUpdating = False
    With ActiveSheet
        Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
        Rt = 2                                  ' start output in row 2
        For R = 2 To Rl                         ' first data row = 2
            Itm = Trim(.Cells(R, "A").Value)
            If InStr(1, Itm, "class", vbTextCompare) = 1 Then
                If Len(Out) Then
                    .Cells(Rt, TargetColumn).Value = Out
                    Rt = Rt + 1
                End If
                Out = Itm
            Else
                If Len(Out) Then
                    If Right(Out, 1) <> "," Then Out = Out & ","
                    Out = Replace(Out, " and", ",") & " "
                End If
                Out = Out & Itm
                If InStr(Out, ",") And (InStr(1, Out, "and", vbTextCompare) = 0) Then
                    Sp = Split(Out, ",")
                    Do
                        Out = Left(Out, Len(Out) - 1)
                    Loop Until Right(Out, 1) = ","
                    Out = Left(Out, Len(Out) - 1) & " and" & Sp(UBound(Sp))
                End If
            End If
        Next R
        If Len(Out) Then .Cells(Rt, TargetColumn).Value = Out
    End With
    Application.ScreenUpdating = True
End Sub

使用If语句和/或ContainWord

2 个答案: