把对应的型号数量按照150拆分，自动增加行数。

cyqs

把对应的型号数量按照150拆分，自动增加行数。表一变成表二的格式。

Datous

。。。。。

准提部林

Sub TEST_A1()
Dim Arr, Brr, i&, k&, V&, N&
Arr = Range([Sheet1!D1], [Sheet1!A65536].End(xlUp))
ReDim Brr(1 To 6000, 1 To 4)
For i = 2 To UBound(Arr)
For j = 2 To 4
    V = Val(Arr(i, j))
    For k = 1 To Int((V - 1) / 150) + 1
        N = N + 1: Brr(N, 1) = Arr(i, 1)
        Brr(N, j) = IIf(V > 150, 150, V)
        V = V - 150
    Next k
j01: Next j
Next i
[Sheet2!A2:D9000].ClearContents
If N > 0 Then [Sheet2!A2].Resize(N, 4) = Brr
End Sub

jiangxiaoyun

Sub ggfg()
    Dim arr, brr()
    arr = [a1].CurrentRegion
    ReDim brr(1 To 55555, 1 To UBound(arr, 2))
    k = 1
    For j = 1 To UBound(brr, 2)
        brr(1, j) = arr(1, j)
    Next
    For i = 2 To UBound(arr)
        For j = 2 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                y = Int(arr(i, j) / 150)
                If y = 0 Then
                    k = k + 1
                    brr(k, 1) = arr(i, 1)
                    brr(k, j) = arr(i, j)
                Else
                    For x = 1 To y
                        k = k + 1
                        brr(k, 1) = arr(i, 1)
                        brr(k, j) = 150
                    Next
                    If arr(i, j) - 150 * y > 0 Then
                        k = k + 1
                        brr(k, 1) = arr(i, 1)
                        brr(k, j) = arr(i, j) - 150 * y
                    End If
                End If
            End If
        Next
    Next
    [g1].Resize(k, UBound(brr, 2)) = brr
End Sub

cjc209

Sub 根据列值扩展行数据()
    Dim Arr, i&, Brr, n&, j&, sl
    Sheet2.Activate
    [g2].CurrentRegion.Offset(1).ClearContents
    Arr = [a1].CurrentRegion
    ReDim Brr(1 To UBound(Arr) * 100, 1 To UBound(Arr, 2))
    For i = 2 To UBound(Arr)
        For j = 2 To UBound(Arr, 2)
            If Arr(i, j) <> "" Then
                cz = Arr(i, j)
                If cz >= 150 Then
                    Do Until cz <= 0
                        If cz > 150 Then
                            dz = 150
                        Else
                            dz = cz
                        End If
                        k = k + 1
                        For l = 1 To UBound(Arr, 2)
                            Brr(k, l) = Arr(i, l)
                        Next
                        cz = cz - 150
                        Brr(k, j) = dz
                    Loop
                End If
                Exit For
            End If
        Next
    Next
    [g2].Resize(k, UBound(Arr, 2)) = Brr
End Sub

microyip

1. Sub 拆分()
   
2.     Dim vData As Variant, nRow As Double, nCol As Long, vFill As Variant, nFill As Double, nVal As Double
   
3.    
   
4.     vData = Sheet2.UsedRange.Resize(, 4).Value
   
5.     vFill = Application.WorksheetFunction.Transpose(vData)
   
6.    
   
7.     ReDim Preserve vFill(1 To 4, 1 To 1)
   
8.     nFill = 1
   
9.     For nRow = 2 To UBound(vData)
   
10.         For nCol = 1 To UBound(vData, 2)
    
11.             nVal = Val(vData(nRow, nCol))
    
12.             Do While nVal > 0
    
13.                 nFill = nFill + 1
    
14.                 ReDim Preserve vFill(1 To 4, 1 To nFill)
    
15.                 vFill(1, nFill) = vData(nRow, 1)
    
16.                 If nVal >= 150 Then
    
17.                     vFill(nCol, nFill) = 150
    
18.                 Else
    
19.                     vFill(nCol, nFill) = nVal
    
20.                 End If
    
21.                 nVal = nVal - vFill(nCol, nFill)
    
22.             Loop
    
23.         Next
    
24.     Next
    
25.     With Sheet3
    
26.         .UsedRange.Delete shift:=xlUp
    
27.         With .[A1].Resize(nFill, 4)
    
28.             .Formula = Application.WorksheetFunction.Transpose(vFill)
    
29.             .EntireColumn.AutoFit
    
30.             .Borders.LineStyle = xlContinuous
    
31.         End With
    
32.     End With
    
33. End Sub

复制代码

microyip

附上附件以供参考

iu950

将原表数据按照150一组拆分形成新表

cjc209

iu950 发表于 2020-11-21 12:46
将原表数据按照150一组拆分形成新表

你这样整 把原始数据都破坏了 不提倡

renkangjizhen

Sub ttt()
Dim arr, x%, y%, m%, n%, k%
k = 2
Sheets("Sheet1").Select
arr = Range("a2:d" & [a65536].End(3).Row)
Sheets("Sheet2").Select
[a2:d1000].ClearContents
For x = 1 To UBound(arr)
    For y = 2 To UBound(arr, 2)
        If arr(x, y) <> "" Then
            m = arr(x, y) \ 150: n = arr(x, y) Mod 150
            If n = 0 Then
            Cells(k, 1).Resize(m, 1) = arr(x, 1): Cells(k, y).Resize(m, 1) = 150
            k = k + m
            Else
            Cells(k, 1).Resize(m + 1, 1) = arr(x, 1): Cells(k, y).Resize(m, 1) = 150: Cells(k + m, y) = n
            k = k + m + 1
            End If
        End If
    Next
Next
End Sub