[已解决]A，B,E,F,G,H,I列相临近相数据一样的自动合并，数据量大，求解。

hwc2ycy · 发表于 2012-10-5 14:07

多列合并工作簿1.rar (16.23 KB, 下载次数: 0)

che_dream · 发表于 2012-10-5 14:20

hwc2ycy 发表于 2012-10-5 14:04
你这个表里前面有二行合并的，我帮你把合并的取消，还原数据的本来面目给你试试。

可以是可以，但是当我的数据更新时候就会没有反应，现在这种情况不能增加新的数据，还有我想C列是数字列，我想和A，B列一样合并，而不是相同合并。谢谢。

wp8680 · 发表于 2012-10-5 14:34

Sub aa()
Dim x As Long
Dim y As Long
Dim z As Long
r = Application.InputBox("请输入要操作的列号")
t = Range(r & 1).Column
q = Range(r & 65536).End(3).Row
For x = 5 To q
y = x + 1
ks:
If Cells(x, t) = Cells(y, t) And y <= q Then
y = y + 1: GoTo ks
Else: z = Cells(y, t).Row - 1
Range(Cells(x, t), Cells(z, t)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
End If
Next
End Sub

复制代码

谁帮我的看看，有一个缺点是每次合并时都得确认下，如何克服？

hwc2ycy · 发表于 2012-10-5 14:40

che_dream 发表于 2012-10-5 14:20
可以是可以，但是当我的数据更新时候就会没有反应，现在这种情况不能增加新的数据，还有我想C列是数字列 ...

Sub 取消合并()
Dim rg As Range
Dim rg2 As Range
Dim irow As Long
irow = [d5].End(xlDown).Row
If Range("d" & irow).Value = "" Then Exit Sub
Set rg = Range(Cells(5, "a"), Cells(irow, "l"))
For Each rg2 In rg
If rg2.MergeCells Then
rg.UnMerge
rg.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Exit For
End If
Next
End Sub

复制代码

你导入新数据后，先运行这个过程，然后再合并，应该没有问题。
C列的数据呆会再帮你想想。

hwc2ycy · 发表于 2012-10-5 14:41

wp8680 发表于 2012-10-5 14:34
谁帮我的看看，有一个缺点是每次合并时都得确认下，如何克服？

Application.DisplayAlerts = False

hwc2ycy · 发表于 2012-10-5 14:45

其实合并之前做数据是否为空的判断就可以不用再改过程了。

hwc2ycy · 发表于 2012-10-5 14:48

这样改后，你追加了新数据，也不成问题。

Sub 合并3()
Dim arr
Dim i As Long, j As Long, k As Long 'I代表列数组，J代表行,K代表列
Dim rg As Range '合并RANGE
Dim iArr '需要合并的列号
Dim irow '数据行数
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iArr = Array(1, 2, 5, 6, 7, 8, 9)
arr = Range("a5:i" & [d5].End(xlDown).Row).Value
irow = UBound(arr)
For i = 0 To UBound(iArr)
k = iArr(i)
For j = 1 To irow
If j = irow Then Exit For
Set rg = Cells(j + 4, k) '行数据与数组中的行数相差为4
Do While arr(j, k) = arr(j + 1, k) And arr(j, k) <> ""
j = j + 1
If j = irow Then Exit Do
Loop
Set rg = Range(rg, Cells(j + 4, k))
rg.Merge
Next
Next
End Sub

复制代码

hwc2ycy · 发表于 2012-10-5 15:30

好了，楼主测测，C列也按要求能合并，然后你新加的数据你也给测测。
我还理下思路，把代码再优化下。

Sub 合并4()
Dim arr
Dim i As Long, j As Long, k As Long 'I代表列数组，J代表行,K代表列
Dim rg As Range '合并RANGE
Dim iArr '需要合并的列号
Dim irow '数据行数
Dim smerge As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iArr = Array(1, 2, 5, 6, 7, 8, 9)
arr = Range("a5:i" & [d5].End(xlDown).Row).Value
irow = UBound(arr)
For i = 0 To UBound(iArr)
k = iArr(i)
For j = 1 To irow
If j = irow Then Exit For
Set rg = Cells(j + 4, k) '行数据与数组中的行数相差为4
Do While arr(j, k) = arr(j + 1, k) And arr(j, k) <> ""
j = j + 1
If j = irow Then Exit Do
Loop
Set rg = Range(rg, Cells(j + 4, k))
rg.Merge
Next
Next
For i = 5 To [d5].End(xlDown).Row
If Range("a" & i).MergeCells Then
smerge = smerge & Range("a" & i).MergeArea.Address & ","
i = Split(Range("a" & i).MergeArea.Address, "$")(4)
End If
Next
Range(Replace(Left(smerge, Len(smerge) - 1), "$A", "$C")).Merge
End Sub

复制代码

hwc2ycy · 发表于 2012-10-5 16:34

Sub 合并5()
'对数据源要求，要求数据源的D列最后一行必须有数据，否则影响程序判断
Dim arr '源数据数组
Dim i As Long, j As Long, k As Long 'I代表列数组，J代表行,K代表列
Dim rg As Range '合并RANGE
Dim iArr '需要合并的列号
Dim irow '数据行数
Dim sMerge As String '合并地址
Dim iLstRow As Long
Dim iMStart
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iLstRow = [d5].End(xlDown).Row '最后一行数据行标
iArr = Array(1, 2, 5, 6, 7, 8, 9)
arr = Range("a5:i" & [d5].End(xlDown).Row).Value '数组，取数据区域
irow = UBound(arr) '数组维数
For i = 0 To UBound(iArr)
k = iArr(i)
sMerge = ""
For j = 1 To irow
If j = irow Then Exit For '最后一行，不做判断，如果是能合并的单元格，下面的代码会做合并。
iMStart = j + 4 '保存合并区起码行号
'Set rg = Cells(iMStart, k) '行数据与数组中的行数相差为4
Do While arr(j, k) = arr(j + 1, k) And arr(j, k) <> ""
j = j + 1
If j = irow Then Exit Do
Loop
If j + 4 > iMStart Then
sMerge = sMerge & Range(Cells(iMStart, k), Cells(j + 4, k)).Address(False, False) & ","
If k = 1 Then sMerge = sMerge & Range(Cells(iMStart, 3), Cells(j + 4, 3)).Address(False, False) & ","
End If
Next
sMerge = Left(sMerge, Len(sMerge) - 1)
Range(sMerge).Merge
Next
End Sub

复制代码

hwc2ycy · 发表于 2012-10-5 16:59

本帖最后由 hwc2ycy 于 2012-10-5 17:04 编辑

今天这道题，学到不少了。
继续改了，免得大规模的数据处理会报错。

Sub 合并6()
'对数据源要求，要求数据源的D列最后一行必须有数据，否则影响程序判断
Dim arr '源数据数组
Dim i As Long, j As Long, k As Long 'I代表列数组，J代表行,K代表列
Dim rg As Range '合并RANGE
Dim iArr '需要合并的列号
Dim irow '数据行数
Dim sMerge As String '合并地址
Dim iLstRow As Long
Dim iMStart
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iLstRow = [d5].End(xlDown).Row '最后一行数据行标
iArr = Array(1, 2, 5, 6, 7, 8, 9)
arr = Range("a5:i" & [d5].End(xlDown).Row).Value '数组，取数据区域
irow = UBound(arr) '数组维数
For i = 0 To UBound(iArr)
k = iArr(i)
For j = 1 To irow
If j = irow Then Exit For '最后一行，不做判断，如果是能合并的单元格，下面的代码会做合并。
iMStart = j + 4 '保存合并区起码行号
'Set rg = Cells(iMStart, k) '行数据与数组中的行数相差为4
Do While arr(j, k) = arr(j + 1, k) And arr(j, k) <> ""
j = j + 1
If j = irow Then Exit Do
Loop
If j + 4 > iMStart Then
If Len(sMerge & Range(Cells(iMStart, k), Cells(j + 4, k)).Address(False, False) & ",") >= 250 Then
sMerge = Left(sMerge, Len(sMerge) - 1)
Range(sMerge).Merge
sMerge = Range(Cells(iMStart, k), Cells(j + 4, k)).Address(False, False) & ","
Else
sMerge = sMerge & Range(Cells(iMStart, k), Cells(j + 4, k)).Address(False, False) & ","
End If
If k = 1 Then
If Len(sMerge & Range(Cells(iMStart, 3), Cells(j + 4, 3)).Address(False, False) & ",") >= 250 Then
sMerge = Left(sMerge, Len(sMerge) - 1)
Range(sMerge).Merge
sMerge = Range(Cells(iMStart, 3), Cells(j + 4, 3)).Address(False, False) & ","
Else
sMerge = sMerge & Range(Cells(iMStart, 3), Cells(j + 4, 3)).Address(False, False) & ","
End If
End If
End If
Next
Next
With Columns("A:L")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Sub

复制代码

		自动登录	找回密码
密码			注册