根据单元格vba的值加入单元格 [英] Join cells based on value of a cell vba

问题描述

这个数据是从.txt文件导入的，还有各种各样的子标题将沿着2,3或4列拆分。

由于数据只能从第一个单元格保留，所以单元格不能合并。

唯一一直是常数的字是B列中的包含和for。

我尝试过的类似于：

如果像包含或 这样的cell.Value，则从一个到列H到列B，将它们集中对齐并使其变为粗体。

谢谢，提前，有任何帮助。 b
$ b

编辑这里是代码：

 子连接（）
 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 LikeSummary *然后
 arr = .Range（.Cells（i，A），.Cells（i，H）） $ b .Cells（z，B）。Value = Join（arr，）
z = z + 1 
 End If 
 Next i 
 End with 
  

End Sub

解决方案

好吧，所以我创建了一个答案，但它不漂亮（有点像我创建的整个项目）。

确定有一种简单的创建方法。

也许有人可以去清理它吗？

  Sub SelRows（）
 
 Dim ocell As Range 
 Dim rng As Range 
 Dim r2 As Range 
 
对于每个ocell In Range（B1：B1000）
 
如果ocell.Value像* contains *那么
 
设置r2 =相交（ocell.EntireRow，列（A：G））
 
如果rng不是，然后
 
设置rng =相交（ocell.EntireRow ，列（A：G）
 Else 
 
设置rng = Union（rng，r2）
如果
结束If 
下一个
 
调用JoinAndMerge 
 
 
如果不是rng是没有，然后rng.Select 
 
设置rng =没有
设置ocell =没有
 End Sub 
 
 Private Sub JoinAndMerge（）
 Dim outputText As String，Rw As Range，cell As Range 
 delim =
 Application.ScreenUpdating = False 
对于每个Rw在Selection.Rows 
对于每个单元格在Rw.Cells 
 outputText = outputText& cell.Value& delim 
下一个单元格
与Rw 
 .Clear 
 .Cells（1）.Value = outputText 
 .Merge 
 .Horizo​​ntalAlignment = xlCenter 
 .VerticalAlignment = xlCenter 
 .WrapText = True 
结束
 outputText =
下一个Rw 
 Application.ScreenUpdating = True 
 End Sub 
  

I am trying to join cells in a row if a value exists in a cell in that row.

The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4 columns.

The cells cant be merged as the data will only be kept from the first cell.

The only words which are always constant are "contain" and "for" in column B.

What I've tried resembles this:

If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.

thanks, in advance, for any help.

Edit Here is the code:

    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

End Sub

解决方案

Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).

It works although I'm sure there is a much simpler way of creating it.

Maybe someone can have a go at cleaning it up?

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

这篇关于根据单元格vba的值加入单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！