vba 使用 VB/Macro 合并多列中的两个单元格
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18130452/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Merging two Cells in multiple columns using VB/Macro
提问by Samit Lal
I would like to merge two cells as one and I have to do that for 2000+ rows (1000+) if merged. I am looking for a macro that will help with this. Below is an example of what I would like to do..
我想将两个单元格合并为一个，如果合并，我必须为 2000+ 行（1000+）这样做。我正在寻找一个可以帮助解决此问题的宏。下面是我想做的一个例子..
I have used the basic macro recorder and its a lot of cells that I have hard code, I have 2003 rows that I need to do the below too.
我使用了基本的宏记录器及其许多硬编码的单元格，我有 2003 行，我也需要执行以下操作。
Sub Macro2()
'
' Macro2 Macro
'
'
Range("A28:A29,C28:C29,E28:E29,F28:F29").Select
Range("F28").Activate
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("A1").Select
End Sub
Below is an example of the data that I want to merge... http://i.stack.imgur.com/US0MG.jpg
下面是我要合并的数据示例... http://i.stack.imgur.com/US0MG.jpg
Number Def Name1 Name2 Group1 Group2
12345 1 abcd 1 2
12345 2 abcd 1 2
123456 1 abcde 5 8
123456 2 abcde 5 8
123789 1 qwert 2 5
123789 2 qwert 2 5
After merging , I would like to see the below: http://i.stack.imgur.com/Pz0tb.jpg
合并后，我想看到以下内容：http: //i.stack.imgur.com/Pz0tb.jpg
Number Def Name1 Name2 Group1 Group2
12345 1 abcd 1 2
2
123456 1 abcde 5 8
2
123789 1 qwert 2 5
2
Thanks for your help in this matter!
感谢您对此事的帮助！
Regards, Samit
问候， 萨米特
采纳答案by Mr.Monshaw
Sub mergerizer()
Application.DisplayAlerts = False
Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row
For myRow = r To 2 Step -1
If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then
For cRow = (myRow - 1) To 1 Step -1
If Range("A" & myRow).Value <> Range("A" & cRow).Value Then
Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 1))
Set rngArray(2) = Range("C" & myRow & ":C" & (cRow + 1))
Set rngArray(3) = Range("E" & myRow & ":E" & (cRow + 1))
Set rngArray(4) = Range("F" & myRow & ":F" & (cRow + 1))
For i = 1 To 4
Set mRng = rngArray(i)
mRng.Merge
With mRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
myRow = cRow + 1
Exit For
End If
Next cRow
End If
Next myRow
Application.DisplayAlerts = True
End Sub
its not crazy elegant but i tested it and it works :) good luck
它不是疯狂的优雅，但我测试了它并且它有效:)祝你好运
