ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 129|回复: 12

[求助] 把对应的型号数量按照150拆分,自动增加行数。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-11-21 10:06 | 显示全部楼层 |阅读模式
把对应的型号数量按照150拆分,自动增加行数。表一变成表二的格式。

原始格式

原始格式

目标格式

目标格式

求助11-21.rar

6.38 KB, 下载次数: 18

TA的精华主题

TA的得分主题

发表于 2020-11-21 10:32 | 显示全部楼层
。。。。。

副本求助11-21.zip

12.25 KB, 下载次数: 1

评分

参与人数 1鲜花 +1 收起 理由
cyqs + 1 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-11-21 10:46 | 显示全部楼层
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


评分

参与人数 1鲜花 +1 收起 理由
cyqs + 1 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-11-21 10:50 | 显示全部楼层
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

评分

参与人数 1鲜花 +1 收起 理由
cyqs + 1 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-11-21 10:59 | 显示全部楼层
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

评分

参与人数 1鲜花 +1 收起 理由
cyqs + 1 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-11-21 11:02 | 显示全部楼层
  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
复制代码

评分

参与人数 1鲜花 +2 收起 理由
cyqs + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-11-21 11:04 | 显示全部楼层
附上附件以供参考

求助11-21(by.micro).rar

12.22 KB, 下载次数: 2

TA的精华主题

TA的得分主题

发表于 2020-11-21 12:46 | 显示全部楼层
将原表数据按照150一组拆分形成新表

按照150一组拆分数据.rar

13.01 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2020-11-21 13:04 | 显示全部楼层
iu950 发表于 2020-11-21 12:46
将原表数据按照150一组拆分形成新表

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

TA的精华主题

TA的得分主题

发表于 2020-11-21 13:30 | 显示全部楼层
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

评分

参与人数 1鲜花 +1 收起 理由
cyqs + 1 感谢帮助

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-12-3 11:38 , Processed in 0.111796 second(s), 25 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表