单元格分拆

ddz79101

翁知江安 发表于 2025-3-16 09:09
供参考，欢迎批评指正

谢谢老师！运行成功！

ddz79101

cjc209 发表于 2025-3-16 09:13
jsa 代码

谢谢老师！

ＥＸＣＥＬ小子

1. Sub SplitInvoicesWithArray()
   
2.     Application.ScreenUpdating = False
   
3.     Application.Calculation = xlCalculationManual
   
4.    
   
5.     Dim ws As Worksheet
   
6.     Set ws = Sheet1
   
7.    
   
8.     Dim originData As Variant
   
9.     Dim resultData() As Variant
   
10.     Dim rowCounter As Long
    
11.     Dim i As Long, j As Long, n As Long
    
12.     ' 读取原始数据到数组
    
13.     With ws
    
14.         Dim lastRow As Long
    
15.         lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
16.         originData = .Range("A2:E" & lastRow).Value ' 排除标题
    
17.     End With
    
18.    
    
19.     ' 计算最大可能行数
    
20.     ReDim resultData(1 To UBound(originData) * 10, 1 To 5) ' 假设每个单元格最多10个发票号
    
21.    
    
22.    
    
23.    
    
24.     ' 主处理循环
    
25.     rowCounter = 0
    
26.     For i = 1 To UBound(originData, 1)
    
27.         Dim invoices() As String
    
28.         invoices = Split(Trim(originData(i, 4)), ",") ' 拆分D列
    
29.         n = 0
    
30.         ' 写入拆分数据
    
31.         For Each inv In invoices
    
32.             If Len(Trim(inv)) > 0 Then
    
33.                 rowCounter = rowCounter + 1
    
34.                 n = n + 1
    
35.                 ' 复制基础数据
    
36.                 If n = 1 Then
    
37.                 For j = 1 To 3
    
38.                     resultData(rowCounter, j) = originData(i, j)
    
39.                 Next j
    
40.                
    
41.                 ' 金额复制
    
42.                 resultData(rowCounter, 5) = originData(i, 5)
    
43.                
    
44.                 End If
    
45.                 ' 发票号处理
    
46.                 resultData(rowCounter, 4) = Trim(inv)
    
47.             End If
    
48.         Next inv
    
49.     Next i
    
50.    
    
51.     ' 清除原始数据
    
52.     ws.Range("i:m").ClearContents
    
53.     ' 处理标题
    
54.     ws.Range("A1:E1").Copy ws.Range("i1")
    
55.     ' 写入处理结果
    
56.     If rowCounter > 0 Then
    
57.         ws.Range("i2").Resize(rowCounter, 5).Value = resultData
    
58.     End If
    
59.    
    
60.     Application.Calculation = xlCalculationAutomatic
    
61.     Application.ScreenUpdating = True
    
62.     MsgBox "处理完成，共生成 " & rowCounter & " 行数据", vbInformation
    
63. End Sub
    
64. 
    

复制代码

ddz79101

ＥＸＣＥＬ小子 发表于 2025-3-16 10:08

谢谢老师！运行成功！