简单表格拆分 可付费 能做的联系

liuch111

拆分后如图  拆分后 b栏不能内容不能重复

hdbk

提供一个思路，在D需要这一列用下面这个公式：=COUNTIF(B2:B12,B2:B12)，然后根据这一列用代码来拆分表格，这种拆分代码网上很多，你可以改一下，我这里就不写了。

zmj9151

用字典应该可实现

小花鹿

可与我联系                                                                                                                     

cjc209

这道题简单 方法多种

cjc209

2楼的就是一种思路 辅助列的公式用=COUNTIF($A$2:A2,A2) 下拉 然后以辅助的序号拆分表格 最后将才出来的表格的辅助列删除就ok了

活在理想的世界

1. Sub d()
   
2. Dim Dic, Eic, arr(), brr(), crr(), w As WorksheetFunction, sht As Worksheet
   
3. Set w = WorksheetFunction: arr = Sheet1.Range("a1").CurrentRegion: crr = Sheet1.Range("a1").Resize(1, 4)
   
4. Set Dic = CreateObject("scripting.dictionary"): Set Eic = CreateObject("scripting.dictionary")
   
5. For i = 2 To UBound(arr)
   
6.     Dic(arr(i, 2)) = Dic(arr(i, 2)) & "," & i: Eic(arr(i, 2)) = Eic(arr(i, 2)) + 1
   
7. Next
   
8. On Error Resume Next
   
9. For i = 1 To w.Max(Eic.Items)
   
10. j = 0: Erase brr: Set sht = Sheets.Add(, Sheets(Sheets.Count)): sht.Name = i
    
11.     For Each ii In Dic.Keys
    
12.     j = j + 1: ReDim Preserve brr(1 To UBound(arr, 2), 1 To j)
    
13.         For c = 1 To UBound(arr, 2)
    
14.         brr(c, j) = arr(Split(Dic(ii), ",")(i), c)
    
15.         Next
    
16.     Next
    
17.     sht.Range("a1").Resize(1, UBound(arr, 2)) = crr
    
18.     sht.Range("a2").Resize(UBound(brr, 2), UBound(arr, 2)) = w.Transpose(brr)
    
19.     sht.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
20. Next
    
21. End Sub

复制代码

11111111111111111111111111111111111111111111111111

活在理想的世界

附件传不上来，假设数据在"数据"表中，然后数据从“数据”表的A1列开始放置。

然后复制楼上代码运行即可。