如何将一行数据切分成多行多列

dafengai

需求描述：
1、将数据源C列生产厂家拆分，每家一行，并标记企业序号，A、B列保留相应的商品编号、商品名。再从D至AL列中取出对应企业的7个字段内容。
2、新建《结果表》并输出，然后对许可证有效期、GMP证有效期、营业执照有效期进行校验，如小于当前日期（即过期失效）则各有效期单元格底色显示为黄色。


数据说明：
1、数据源C列（生产厂家）每行最多有5家企业，用分号“；”进行分隔，不足5家的，企业名称为空，但仍保留分号。
2、数据源C列中每家企业均包含“生产许可证号、生产许可证获证日期、许可证有效期、GMP证号、GMP证有效期、营业执照证号、营业执照有效期”7个字段，字段名末尾标注数字1至5，依次对应C列中5家企业，如不足5家的，内容留空。


>>>>拆分厂家，可以实现，但是将一行切分成多行不知道怎么实现？数据有几万行，而且频繁需要将表格数据进行转换，希望高人出手“搭救”，非常感谢！


Sub mySplit()
'//////参考“VBA编程实战”的代码
    Dim ws As Worksheet
    Dim Arr(), ArrG() As String, ArrTem(), arrH()
     Arr = Sheet1.UsedRange   '表1写入数组Arr
    Set ws = Sheet2
    m = 1
    With ws
        .Cells(1, 1).CurrentRegion.Offset(1, 0).Clear
        For i = 2 To UBound(Arr)   '循环数据源
            ArrG = Split(Arr(i, 3), "；")   '拆分厂家，写入一维数组ArrG
            For j = LBound(ArrG) To UBound(ArrG)   '循环拆分厂家
                ReDim Preserve ArrTem(1 To 10, 1 To m)   '构建9行m列的数组ArrTem
                For k = 1 To 2
                    ArrTem(k, m) = Arr(i, k)
                Next k
                ArrTem(3, m) = ArrG(j)
                m = m + 1
            Next j
        Next i
        .Cells(2, 1).Resize(UBound(ArrTem, 2), UBound(ArrTem)) = Application.WorksheetFunction.Transpose(ArrTem)
        .Activate
    End With
  End Sub

山菊花

供参考。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.29
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("数据源")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 10)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr) * 5, 1 To 11)
   
8.     For i = 2 To UBound(arr)
   
9.         b = Split(arr(i, 3), "；")
   
10.         For x = 0 To UBound(b)
    
11.             m = m + 1
    
12.             brr(m, 1) = arr(i, 1)
    
13.             brr(m, 2) = arr(i, 2)
    
14.             brr(m, 3) = "厂家" & x + 1
    
15.             brr(m, 4) = b(x)
    
16.             For j = 4 To UBound(arr, 2)
    
17.                 brr(m, j + 1) = arr(i, j)
    
18.             Next
    
19.         Next
    
20.     Next
    
21.     With Sheets("结果表")
    
22.         .UsedRange.Offset(1).Clear
    
23.         With .[a2].Resize(m, 11)
    
24.             .Value = brr
    
25.             .Borders.LineStyle = 1
    
26.             .HorizontalAlignment = xlCenter
    
27.             .VerticalAlignment = xlCenter
    
28.         End With
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("数据源")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
7.         arr = .Range("a2").Resize(r - 1, c)
   
8.     End With
   
9.     ReDim brr(1 To UBound(arr) * 5, 1 To 11)
   
10.     m = 0
    
11.     For i = 1 To UBound(arr)
    
12.         xm = Split(arr(i, 3), "；")
    
13.         For j = 0 To UBound(xm)
    
14.             n = j * 7 + 4
    
15.             m = m + 1
    
16.             brr(m, 1) = arr(i, 1)
    
17.             brr(m, 2) = arr(i, 2)
    
18.             brr(m, 3) = "厂家" & j + 1
    
19.             brr(m, 4) = xm(j)
    
20.             For k = 1 To 7
    
21.                 brr(m, 4 + k) = arr(i, n + k - 1)
    
22.             Next
    
23.         Next
    
24.     Next
    
25.     With Worksheets("结果表")
    
26.         .UsedRange.Offset(1, 0).Clear
    
27.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.         For i = 1 To UBound(brr)
    
29.             For Each y In Array(7, 9, 11)
    
30.                 If Len(brr(i, y)) <> 0 Then
    
31.                     If brr(i, y) < Date Then
    
32.                         .Cells(1 + i, y).Interior.ColorIndex = 6
    
33.                     End If
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.     End With
    
38. End Sub
    

复制代码

chxw68

练习一下。

cnmlgb9998

用PQ 实现第一步。后面着色 没办法。

dafengai

山菊花 发表于 2024-4-29 06:39
供参考。

非常感谢版主大大，代码可以运行。用实际数据测试了一下，生产厂家增加到10个，行数达到4万行时，会报溢出，修改变量的数据类型后可解决——Dim nRow%,  m%改为Dim nRow&,  m&。慢慢摸索，又学会了一个知识点：定义的变量为短整型，当数据超过32767后就会溢出。

dafengai

cnmlgb9998 发表于 2024-4-29 11:19
用PQ 实现第一步。后面着色 没办法。

非常感谢提供了另一个思路，有时间也学一下PQ

dafengai

ykcbf1100 发表于 2024-4-29 08:57
参与一下。。。

感谢您的帮助。不过还是出了一点问题，相关证照没有按照1至5分别与厂家1-5对应，都只取了第一组的