合并单元格格式变换VBA

yishang3

有许多不同种合并单元格格式的表格，需要规范化数据！具体要求： 合并单元格拆分.rar (8.54 KB, 下载次数: 8)

2020-2-17 16:16 上传

点击文件名下载附件

1、合并单元格列不固定，但每一组数据行数相同。2、没有合并的单元格数据最后合并到一个单元格去，不同行的数据以中间用换行符。
3、模拟结果如结果表。
请群里的大师帮忙看一下，看是否能够解决！谢谢！

syj2004hg

数据量少的话可以直接用合并单元格命令

1. Sub mg()
   
2.     Application.DisplayAlerts = False
   
3.     Application.ScreenUpdating = False
   
4.     Dim rng As Range, c As Long, i As Long, j As Long
   
5.     For i = 2 To UsedRange.Rows.Count
   
6.         If Cells(i, 1) <> "" Then
   
7.             c = Cells(i, 1).MergeArea.Rows.Count
   
8.             For j = 1 To c - 1
   
9.                 Cells(i, 5) = Cells(i, 5) & vbCrLf & Cells(i + j, 5)
   
10.                 Cells(i, 6) = Cells(i, 6) & vbCrLf & Cells(i + j, 6)
    
11.             Next j
    
12.             Cells(i, 5).Resize(c, 1).Merge
    
13.             Cells(i, 6).Resize(c, 1).Merge
    
14.             i = i + c - 1
    
15.         End If
    
16.     Next
    
17.     Application.ScreenUpdating = True
    
18.     Application.DisplayAlerts = False
    
19. End Sub

复制代码

yishang3

syj2004hg 发表于 2020-2-17 17:11
数据量少的话可以直接用合并单元格命令

1. Sub mg()
   
2.     Application.DisplayAlerts = False
   
3.     Application.ScreenUpdating = False
   
4.     Dim rng As Range, c As Long, i As Long, j As Long
   
5.     For y = 2 To Sheet1.UsedRange.Columns.Count
   
6.     For i = 2 To Sheet1.UsedRange.Rows.Count
   
7.         If Cells(i, 1) <> "" Then
   
8.             c = Cells(i, 1).MergeArea.Rows.Count
   
9.            
   
10.             If Cells(i, "y").MergeCells = False Then
    
11.             For j = 1 To c - 1
    
12.             If Cells(i + j, y) <> "" Then
    
13.                Cells(i, y) = Cells(i, y) & vbCrLf & Cells(i + j, y)
    
14.                End If
    
15.             Next j
    
16.            Cells(i, y).Resize(c, 1).Merge
    
17.             i = i + c - 1
    
18.         End If
    
19.         End If
    
20.     Next
    
21.     Next
    
22.    Sheet1.UsedRange.UnMerge
    
23.     Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
24.     Application.ScreenUpdating = True
    
25.     Application.DisplayAlerts = False
    
26. End Sub

复制代码

谢谢您的帮助！在您的基础上修改了一下代码，可以适应多种条件