诚心求助大神：用VBA将相同列标题剪切合并

山林草根

各大神新年好：用VBA将相同列标题剪切合并，谢谢啦

山菊花

供参考。

山林草根

山菊花 发表于 2024-2-12 18:12
供参考。

万分感谢山菊花的帮助经初步测试您的代码达到了要求，祝您龙年万事顺利！身体健康！阖家幸福！

gwjkkkkk

感觉写得复杂了。
Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, r&, k&, m&, n&, dic As Object, vKey, t#
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    With Sheets(2).[A1].CurrentRegion
        ReDim ar(1 To .Columns.Count)
        For j = 1 To UBound(ar)
            ar(j) = Range(.Cells(1, j), .Cells(Rows.Count, j).End(xlUp)).Value
            If Not dic.exists(ar(j)(1, 1)) Then
                dic(ar(j)(1, 1)) = UBound(ar(j))
            Else
                dic(ar(j)(1, 1)) = dic(ar(j)(1, 1)) + UBound(ar(j)) - 1
            End If
        Next j
    End With
   
    Cells.Clear
    For Each vKey In dic.keys
        ReDim br(1 To dic(vKey), 1 To 1)
        n = 0: r = 0
        For j = 1 To UBound(ar)
            If ar(j)(1, 1) = vKey Then
                 n = n + 1
                 If n > 1 Then k = 2 Else k = 1
                 For i = k To UBound(ar(j))
                     r = r + 1
                     br(r, 1) = ar(j)(i, 1)
                 Next i
            End If
        Next j
        br = cutArray1(br, 1048575)
        For i = 1 To UBound(br)
            m = m + 1
            Cells(1, m).Resize(UBound(br(i))) = br(i)
        Next i
    Next
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub
Function cutArray1(ByVal ar, iCutNum&, Optional iHeader& = 1) As Variant
    Dim br(), cr, i&, j&, iPosRow&, r&, k&
    For i = iHeader + 1 To UBound(ar) Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > UBound(ar), (UBound(ar) - iHeader) Mod iCutNum, iCutNum)
        ReDim cr(1 To iPosRow + iHeader, 1 To UBound(ar, 2))
        For j = iHeader + 1 To UBound(cr)
            For k = 1 To UBound(cr, 2)
               cr(j, k) = ar(i - 1 + j - iHeader, k)
            Next k
        Next j
        For j = 1 To iHeader
            For k = 1 To UBound(cr, 2)
                cr(j, k) = ar(j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = cr
    Next i
    cutArray1 = br
End Function

gwjkkkkk

参与一下。。。

山林草根

gwjkkkkk 发表于 2024-2-13 14:08
参与一下。。。

感谢gwjkkkkk您的代码可以复制到另外一个新的工作薄运行这样比较方便，谢谢您的帮助

山林草根

gwjkkkkk 发表于 2024-2-13 14:08
参与一下。。。

再次请教gwjkkkkk高手您好：您帮助编写的“将相同列标题的数据剪切合并”的VBA按钮在sheet4执行后数据由原来在sheet2输出结果在sheet4.现在想将数据放在sheet1处理后输出结果在sheet2.上面代码如何改呢？如果有大量数据能否直接将数据结果输出到sheet1呢？这样就节省一倍的内存了。谢谢再次帮忙！

gwjkkkkk

1.数据放在sheet1处理后输出结果在sheet2，请参考。。。

gwjkkkkk

2.大量数据直接将数据结果输出到sheet1，但原始数据为清除。。。

山林草根

真牛，正是想要的结果