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

Question

如果該行的某個單元格中存在值，我將嘗試連接該行中的單元格。

數據已從.txt文件中導入，並且各種子標題分為2、3或4列。

單元不能合並，因為數據只會保留在第一個單元中。

B列中唯一始終不變的單詞是“包含”和“ for”。

我嘗試過的類似於：

如果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 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

Answer 2

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

盡管我敢肯定有一種更簡單的創建方法，但它仍然有效。

也許有人可以去清理它？

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