同一产品多批次生产日期及对应箱数横向排列

aquariusxiao

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

①“匹配”这页是源数据，同一个商品会有多个生产日期的情况，如红框（2个产生日期）和蓝框（3个生产日期）所示
②“电子送货单”这页，需要将同一商品号对应的不同的生产日期及其对应的箱数进行横向排列，如红框和蓝框所示
③“匹配”这页源数据行数较多，一般有100多行，可能会有同一商品不同生产日期不连续排列，隔了几行的情况

“电子送货单”这页的E-J列是我手工做的最终效果，供老师们参考

shiruiqiang

shiruiqiang

如果有相同日期或者超出3个日期，写法要不同

ynzsvt

超出3个将出错（后面被覆盖）

aquariusxiao

shiruiqiang 发表于 2025-7-6 07:26
如果有相同日期或者超出3个日期，写法要不同

老师您好，您写的完全和需求的一样，感谢您的指导。
我测试了下源数据超过60行时会报错“下标越界”，没有相同日期也不超出3个日期，无论填什么都会报错
不好意思老师我是小白，研究了半天实在不知道该如何修改，您能否再帮忙指导下，再次感谢

shiruiqiang

aquariusxiao 发表于 2025-7-6 11:28
老师您好，您写的完全和需求的一样，感谢您的指导。
我测试了下源数据超过60行时会报错“下标越界”，没 ...

我模拟到70多行都没问题，要不发附件

ynzsvt

1. Sub Test()
   
2. Dim Dic As Object, Lj, LastR&, i&, j&, k&, St$, Br, FirstR&
   
3. FirstR = 11
   
4. Br = Array(, "w", "c", "d", "aa")
   
5. 
   
6. Application.Intersect(Columns("A:Q"), ActiveSheet.UsedRange).Offset(FirstR - 1).ClearContents
   
7. Set Dic = CreateObject("Scripting.Dictionary")
   
8. With Worksheets("匹配")
   
9. LastR = .Cells(Rows.Count, "P").End(xlUp).Row
   
10. ReDim Lj(FirstR To LastR + FirstR) 'FO的列号
    
11. For i = 2 To LastR
    
12.   St = .Cells(i, "P")
    
13.   If Not Dic.Exists(St) Then
    
14.    j = Dic.Count + FirstR: Dic(St) = j: Lj(j) = 5
    
15.    For k = 1 To UBound(Br)
    
16.     Cells(j, k) = .Cells(i, Br(k))
    
17.    Next
    
18.    For k = 11 To 16: Cells(j, k) = .Cells(i, k + 5): Next
    
19.    Cells(j, 17) = .Cells(i, "V") & .Cells(i, "Y") & .Cells(i, "X")
    
20.   Else
    
21.    j = Dic(St): Lj(j) = Lj(j) + 2
    
22.   End If
    
23.   Cells(j, Lj(j)) = .Cells(i, "F")
    
24.   Cells(j, Lj(j) + 1) = .Cells(i, "O")
    
25. Next
    
26. End With
    
27. Set Dic = Nothing
    
28. End Sub

复制代码

ynzsvt

1. Sub Test()
   
2. Dim Dic As Object, Lj, LastR&, i&, j&, k&, St$, Br, FirstR&
   
3. FirstR = 11
   
4. Br = Array(, "w", "c", "d", "aa")
   
5. 
   
6. Application.Intersect(Columns("A:Q"), ActiveSheet.UsedRange).Offset(FirstR - 1).ClearContents
   
7. Set Dic = CreateObject("Scripting.Dictionary")
   
8. With Worksheets("匹配")
   
9. LastR = .Cells(Rows.Count, "P").End(xlUp).Row
   
10. ReDim Lj(FirstR To LastR + FirstR) 'FO的列号
    
11. For i = 2 To LastR
    
12.   St = .Cells(i, "P")
    
13.   If Not Dic.Exists(St) Then
    
14.    j = Dic.Count + FirstR: Dic(St) = j: Lj(j) = 5
    
15.    For k = 1 To UBound(Br)
    
16.     Cells(j, k) = .Cells(i, Br(k))
    
17.    Next
    
18.    For k = 11 To 16: Cells(j, k) = .Cells(i, k + 5): Next
    
19.    Cells(j, 17) = .Cells(i, "V") & .Cells(i, "Y") & .Cells(i, "X")
    
20.   Else
    
21.    j = Dic(St): Lj(j) = Lj(j) + 2
    
22.   End If
    
23.   Cells(j, Lj(j)) = .Cells(i, "F")
    
24.   Cells(j, Lj(j) + 1) = .Cells(i, "O")
    
25. Next
    
26. End With
    
27. Set Dic = Nothing
    
28. End Sub

复制代码

yanglinzi

参与一下。。。。

yanglinzi