有N列和N行数据,按名称合并到一列中，大佬这种效果用宏能不能完成

噶个人

新建 Microsoft Excel 工作表 (6).zip (7.09 KB, 下载次数: 4)

2024-8-17 15:24 上传

点击文件名下载附件

有N列和N行数据，按名称合并到下列中,遇到空值（不包括0）自动按名称选取下一列进行排列

ynzsvt

提问也太精炼了，建议回炉熔化。

一招秒杀

这不就分别复制、粘贴，再复制、再粘贴，就完美解决了吗 简单的不要不要的

噶个人

一招秒杀 发表于 2024-8-17 13:31
这不就分别复制、粘贴，再复制、再粘贴，就完美解决了吗 简单的不要不要的

数据少好弄，数据多就有些麻烦了

只是、那个人

看不懂价格和商品的关系，你的要求只是将多列合并成一列并去除重复值？
但是看你模拟的合并  商品价格有变化  但是这个变化既不像求和也不像单价。。。

只是、那个人

一招秒杀 发表于 2024-8-17 13:31
这不就分别复制、粘贴，再复制、再粘贴，就完美解决了吗 简单的不要不要的

好像是这个道理，复制多列到一列然后定位空单元格删除下方单元格上移

ynzsvt

1. Sub 简单独立合并()
   
2. Dim Arr, i, j, k, n, m, Dic As Object, Brr
   
3. Set Dic = CreateObject("Scripting.Dictionary")
   
4. Arr = [a1].CurrentRegion.Resize(999) '给足够的行数
   
5. ReDim Brr(1 To 9) '给足够的列数
   
6. 
   
7. For i = 1 To UBound(Arr, 2)
   
8.   If Not Dic.Exists(Arr(1, i)) Then
   
9.    Dic(Arr(1, i)) = Dic.Count + 1
   
10.    k = Dic(Arr(1, i)): n = 1
    
11.    For j = 1 To UBound(Arr)
    
12.     If Arr(j, i) = "" Then Exit For
    
13.     Arr(n, k) = Arr(j, i)
    
14.     n = n + 1
    
15.    Next
    
16.     Brr(k) = n
    
17.   Else
    
18.    k = Dic(Arr(1, i)): n = Brr(k)
    
19.    For j = 2 To UBound(Arr)
    
20.     If Arr(j, i) = "" Then Exit For
    
21.     Arr(n, k) = Arr(j, i)
    
22.     n = n + 1
    
23.    Next
    
24.     Brr(k) = n
    
25.   End If
    
26. Next
    
27. 
    
28. '输出的左上角自己改变
    
29. [I1].Resize(UBound(Arr) - 1, Dic.Count) = Arr
    
30. Set Dic = Nothing
    
31. End Sub

复制代码

噶个人

ynzsvt 发表于 2024-8-17 15:01

给大佬点赞，就是这个意思，非常感谢

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, k&, r&, n&, m&
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To 10 ^ 3, 1 To 3)
    With [A1].CurrentRegion '.Value
        
    For j = 1 To .Columns.Count Step 3
        n = n + 1
        br = .Cells(1, j).Resize(.Rows.Count, 3).Value
        If n > 1 Then m = 2 Else m = 1
        For i = m To UBound(br)
            If Len(br(i, 1)) Then
                r = r + 1
                For k = 1 To UBound(br, 2)
                    ar(r, k) = br(i, k)
                Next k
            End If
        Next i
    Next j
    End With
   
    [R1].Resize(r, 3) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

.....................