几个单元格内容合并仍保留原来的字体颜色

li446425169

     在"数据"工作表中把指定区域（行）几个单元格内容合并在另外同一行指定单元格内，
并且字体颜色保留原来的，每个单元格内容和另外一个单元格内容之间保留3个空格。
这样的合并单元格最多100行数据

A列至E列数据列
G列合并后数据存放列
这些列麻烦在代码中特别指定或者注释，后期可能会按照其他区域位置修改

哪位老师有空请帮助
谢谢

gwjkkkkk

请楼主参考 。。。

xzcdcak

xzcdcak

Sub test() 'https://club.excelhome.net/thread-1639231-1-1.html
    Dim i As Integer, endrow As Integer
    Dim arr()
    Dim brr()
    endrow = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表的最后一个非空行号
    arr = Range("A3:E" & endrow) '修改这里就可以修改数据源区域
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        brr(i, 1) = arr(i, 1) & "   " & arr(i, 2) & "   " & arr(i, 3) & "   " & arr(i, 4) & "   " & arr(i, 5)
    Next
    Range("G3:G" & endrow) = brr()修改这里可以修改输出结果的区域
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            a = InStr(brr(i, 1), arr(i, j))
            If a <> 0 Then
                b = Len(arr(i, j))
                c = Cells(i + 2, j).Font.Color
                Cells(i + 2, 7).Characters(Start:=a, Length:=b).Font.Color = c
                '这里的7以后要改成你需要存数据的列数。现在是G所以是abcdefg 第七个。
            Else
            End If
        Next
    Next
End Sub

小象啊啊

请参考附件

xzcdcak

gwjkkkkk 发表于 2022-9-7 20:38
请楼主参考 。。。

学习了。join(index(arr,i),"   ")
受教了。

li446425169

gwjkkkkk 发表于 2022-9-7 20:38
请楼主参考 。。。

老师你好，谢谢您的帮助

我试了一下如果改变数据区域，代码好像就不能用了，是不是只能是在1楼附件内的数据区域使用

1. Sub 按钮1_Click()
   
2. Dim iRow&, arr, T&, i&, j&, str$
   
3. iRow = Cells(Rows.Count, 1).End(xlUp).Row
   
4. arr = Range("e1:K" & iRow)
   
5. T = 1
   
6. For i = 3 To UBound(arr)
   
7.       Cells(i, 14) = Join(Application.Index(arr, i), "   ")
   
8.       For j = 1 To UBound(arr, 2)
   
9.           Cells(i, 14).Characters(Start:=T, Length:=Len(arr(i, j))).Font.Color = Cells(i, j).Font.Color
   
10.           T = Len(arr(i, j)) + 3 + T
    
11.       Next j
    
12.       T = 1
    
13. Next
    
14. End Sub

复制代码

li446425169

xzcdcak 发表于 2022-9-7 21:02
Sub test() 'https://club.excelhome.net/thread-1639231-1-1.html
    Dim i As Integer, endrow As Inte ...

谢谢老师的帮助
发现一点小问题，如果数据区域内有一些没填充的数据单元格就会出错
谢谢

li446425169

xzcdcak 发表于 2022-9-7 21:02
Sub test() 'https://club.excelhome.net/thread-1639231-1-1.html
    Dim i As Integer, endrow As Inte ...

老师，我按照你留的注释修改区域就出错了，字体颜色不能变

1. Sub test() 'https://club.excelhome.net/thread-1639231-1-1.html
   
2.     Dim i As Integer, endrow As Integer
   
3.     Dim arr()
   
4.     Dim brr()
   
5.     endrow = Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表的最后一个非空行号
   
6.     arr = Range("E6:K" & endrow) '修改这里就可以修改数据源区域
   
7.     ReDim brr(1 To UBound(arr), 1 To 1)
   
8.     For i = 1 To UBound(arr)
   
9.         brr(i, 1) = arr(i, 1) & "   " & arr(i, 2) & "   " & arr(i, 3) & "   " & arr(i, 4) & "   " & arr(i, 5)
   
10.     Next
    
11.     Range("N6:N" & endrow) = brr()'修改这里就可以修改存放列
    
12.     For i = 1 To UBound(arr)
    
13.         For j = 1 To UBound(arr, 2)
    
14.             a = InStr(brr(i, 1), arr(i, j))
    
15.             If a <> 0 Then
    
16.                 b = Len(arr(i, j))
    
17.                 c = Cells(i + 2, j).Font.Color
    
18.                 Cells(i + 2, 14).Characters(Start:=a, Length:=b).Font.Color = c
    
19.                 '这里的14以后要改成你需要存数据的列数。现在是n所以是14
    
20.             Else
    
21.             End If
    
22.         Next
    
23.     Next
    
24. End Sub
    

复制代码

xzcdcak

li446425169 发表于 2022-9-8 18:43
谢谢老师的帮助
发现一点小问题，如果数据区域内有一些没填充的数据单元格就会出错
谢谢

你自己提出的要求时，也没说有的区域会有空白啊？不管是谁都不可能知道你到底想要什么。
希望你把你想要的全部在附件里体现出来。
一、有空白的地方
二、要换区域就得改代码。你看到range了吗？自己改一下不就可以了。你是完全不会吗？
如果等投喂那你就要把你所有可能出现的情况都要给出来。别人才能帮到你。