按单元格命名批量拆分表格及对应数据

aquariusxiao

各位老师，大致需求如下：

①根据A列唯一值，批量拆分若干新的excel表格，新表格文件名以A列唯一值分别命名
②新生成的excel表中的A-H列，取新表文件名所对应的原表格B-I列数据

附件中的源文件是需要拆分的原表，其他三个表是我手工拆分后的结果，供老师们参考

醉眼看尘世

1. Sub test()
   
2. Dim Dic As Object, wB As Workbook, Arr, sH As Worksheet, mFile$, mPath$
   
3. Dim i&, j&, hS&
   
4. Set Dic = CreateObject("scripting.dictionary")
   
5. Set sH = ActiveSheet
   
6. With sH
   
7.     mrow = .Cells(.Rows.Count, "A").End(3).Row
   
8.     Arr = .[a1].Resize(mrow, 9)
   
9. End With
   
10. For i = 2 To UBound(Arr, 1)
    
11.     If Arr(i, 1) <> "" Then
    
12.         If Dic.exists(Arr(i, 1)) Then Dic(Arr(i, 1)) = Dic(Arr(i, 1)) & Chr(10) & i Else Dic(Arr(i, 1)) = i
    
13.     End If
    
14. Next i
    
15. mPath = ThisWorkbook.Path
    
16. For Each d In Dic.keys
    
17.     mFile = mPath & "" & d & ".xlsx"
    
18.     If Dir(mFile) <> "" Then Kill mFile
    
19.     Set wB = Workbooks.Add
    
20.     Set sH = wB.Worksheets(1)
    
21.     With sH
    
22.         Trr = Split(Dic(d), Chr(10))
    
23.         ReDim brr(1 To UBound(Trr) + 2, 1 To UBound(Arr, 2) - 1)
    
24.         For j = 2 To UBound(Arr, 2)
    
25.             brr(1, j - 1) = Arr(1, j)
    
26.         Next j
    
27.         For i = 0 To UBound(Trr)
    
28.             hS = Val(Trr(i))
    
29.             For j = 2 To UBound(Arr, 2)
    
30.                 brr(i + 2, j - 1) = Arr(hS, j)
    
31.             Next j
    
32.         Next i
    
33.         .[a1].Resize(UBound(brr, 1), UBound(brr, 2) - 1).NumberFormat = "@"
    
34.         .[h2].Resize(UBound(brr, 1), 1).NumberFormatLocal = "yyyy-mm-dd"
    
35.         .[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
36.         .UsedRange.EntireColumn.AutoFit
    
37.     End With
    
38.     wB.SaveAs mFile, 51
    
39.     wB.Close 0
    
40. Next d
    
41. End Sub
    

复制代码

cai2532

参与一下。

longwin

请看附件。。。。

醉眼看尘世

醉眼看尘世 发表于 2024-8-19 12:38

mFile = mPath & "" & d & ".xlsx"
这一句应为
mFile = mPath & "\" & d & ".xlsx"

Qs18

Sub qs()
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Dim arr, i, dick, xb As Workbook, rng As Range, ph
ph = ThisWorkbook.Path & "\"
Set rng = [b1:i1]
arr = Sheet2.Range("a1").CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To 8)
Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        If Len(s) > 0 Then
            dic(s) = ""
        End If
    Next
For Each k In dic.keys
m = 0
Set xb = Workbooks.Add
For i = 2 To UBound(arr)
  s = arr(i, 1)
  If Len(s) > 0 Then
    If s = k Then
        m = m + 1
        For j = 1 To UBound(brr, 2)
            brr(m, j) = arr(i, j + 1)
        
        Next
    End If
  
  End If
Next
rng.Copy xb.Sheets(1).[a1]
xb.Sheets(1).[a2].Resize(m, UBound(brr, 2)) = brr
xb.Sheets(1).Cells.EntireColumn.AutoFit
xb.SaveAs ph & k & ".xlsx"
xb.Close
Next
Set dic = Nothing: Set rng = Nothing: Set xb = Nothing
Application.DisplayAlerts = True: Application.ScreenUpdating = True
MsgBox "完成！"
End Sub

Qs18

试试.........

Qs18

试试..........

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()      '//2024.8.19
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Dim tm: tm = Timer
   
6.     col = 1     '//拆分列号
   
7.     p = ThisWorkbook.Path & ""
   
8.     Set sh = ThisWorkbook.Sheets("合规文件")
   
9.     With sh
   
10.         r = .Cells(Rows.Count, 4).End(3).Row
    
11.         arr = .Range("a1:i" & r)
    
12.         c = UBound(arr, 2)
    
13.         Set rng = .Rows(1)
    
14.         For i = 2 To UBound(arr)
    
15.             s = arr(i, col)
    
16.             If Len(s) Then
    
17.                 If Not d.Exists(s) Then
    
18.                     Set d(s) = Union(rng, .Rows(i))
    
19.                 Else
    
20.                     Set d(s) = Union(d(s), .Rows(i))
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.     End With
    
25.     For Each k In d.keys
    
26.         With Workbooks.Add
    
27.             With .Sheets(1)
    
28.                 .Name = k
    
29.                 d(k).Copy .[a1]
    
30.                 .Columns(1).Delete
    
31.                 .DrawingObjects.Delete
    
32.             End With
    
33.             .SaveAs p & k
    
34.             .Close 1
    
35.         End With
    
36.     Next
    
37.     Set rng = Nothing
    
38.     Set d = Nothing
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
41. End Sub
    
42. 
    

复制代码