根据细胞vba的值join细胞

如果在该行的单元格中存在一个值,我试图连接一行中的单元格。

数据已经从.txt文件导入,不同的子标题分为2,3或4列。

这些单元格不能合并,因为数据只能从第一个单元格保存。

在B栏中总是保持不变的是“包含”和“为”。

我所尝试过的类似于:

如果cell.Value像“contains”或“ for ”那么将列“A”到列“H”的所有单元格连接到列“B”中,将它们居中alignment并使它们变为粗体。

提前感谢您的帮助。

编辑这里是代码:

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 

结束小组

不知道这是否正是你想要的,但它会让你closures:

 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 

好吧,我已经创build了一个答案,但它不漂亮(有点像我创build的整个项目)。

它工作,虽然我确信有一个更简单的方式来创build它。

也许有人可以去清理它?

 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