根據單元格的值加入單元格vba

Question

如果在該行單元格中存在值，我試圖在單元格中加入單元格。

數據已從.txt文件導入，各種子標題沿着2,3或4列分開。

這些單元格不能合併，因爲數據只會保留在第一個單元格中。

它總是常數「遏制」和「」唯一的詞在B列

我已經試過類似於此：

如果cell.Value像「含有」或「」爲「，然後將列」A「到列」H「的所有單元格連接到列」B「中，將它們居中對齊並使它們變爲粗體。

感謝，提前，任何幫助。

編輯下面是代碼：

Sub Joining() 
    Dim N As Long, i As Long, r1 As Range, r2 As Range 
Dim z As Long 
Dim arr() As Variant 
z = 1 

With Activesheet 
    N = .Cells(Rows.Count, "A").End(xlUp).Row 
    For i = 1 To N 
     If .Cells(i, "B").Value Like "Summary*" Then 
      arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value 
      .Cells(z, "B").Value = Join(arr, " ") 
      z = z + 1 
     End If 
    Next i 
End With 

末次

Answer 1

好了，我已經創造了一個答案，但它並不漂亮（有點像我創建的整個項目）。

它的工作原理雖然我確信有一個更簡單的方法來創建它。

也許有人可以去清理它？

Sub SelRows() 

Dim ocell As Range 
Dim rng As Range 
Dim r2 As Range 

For Each ocell In Range("B1:B1000") 

    If ocell.Value Like "*contain*" Then 

     Set r2 = Intersect(ocell.EntireRow, Columns("A:G")) 

     If rng Is Nothing Then 

      Set rng = Intersect(ocell.EntireRow, Columns("A:G")) 
     Else 

      Set rng = Union(rng, r2) 
     End If 
    End If 
Next 

Call JoinAndMerge 


If Not rng Is Nothing Then rng.Select 

Set rng = Nothing 
Set ocell = Nothing 
End Sub 

Private Sub JoinAndMerge() 
Dim outputText As String, Rw As Range, cell As Range 
delim = " " 
Application.ScreenUpdating = False 
For Each Rw In Selection.Rows 
For Each cell In Rw.Cells 
    outputText = outputText & cell.Value & delim 
Next cell 
With Rw 
.Clear 
.Cells(1).Value = outputText 
.Merge 
.HorizontalAlignment = xlCenter 
.VerticalAlignment = xlCenter 
.WrapText = True 
End With 
outputText = "" 
Next Rw 
Application.ScreenUpdating = True 
End Sub 

Answer 2

不知道這是否是你想要的是什麼，但它會讓你接近：

Sub summary() 
    Dim sh1 As Worksheet, sh2 As Worksheet 
    Dim N As Long, i As Long, r1 As Range, r2 As Range 
    Dim z As Long 
    Dim arr() As Variant 
    z = 1 
    Set sh1 = ActiveSheet 
    With ActiveWorkbook 
     Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count)) 
    End With 

    With sh1 
     N = .Cells(Rows.Count, "A").End(xlUp).Row 
     For i = 1 To N 
      If .Cells(i, "A").Value Like "Summary*" Then 
       arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value 
       sh2.Cells(z, "A").Value = Join(arr, " ") 
       z = z + 1 
      End If 
     Next i 
    End With 
End Sub