设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 有难度的VBA转置处理问题
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 3774|回复: 16

[已解决]有难度的VBA转置处理问题

[复制链接]
发表于 2013-4-21 13:56 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请高手帮助实现如下结果,谢谢了!!
-------------------------------------------
根据"订单排期"工作表,生成"单价编号"工作表
1\订单批号\订单数量\不变
2\产品名称变为工序代码:第一道工序前面加"1"各个加工为01….第二道工序前面加"2"各个加工为01…..
3\工序名称\工序单价转置列出
用此表转置:
T7TYC__%)XMQ4Q4C_W{{5Q6.jpg
转置结果:
YKRQUDLE[YN~93V$GAHHXVH.jpg
用VBA转置处理提高速度2003.zip (22.93 KB, 下载次数: 18)
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-4-21 14:12 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
这个用数透应该可以啊。

看反了，{:4012:}

回复

使用道具 举报

hwc2ycy
发表于 2013-4-21 14:41 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub 转置数据()
  2.     Dim arr, result()
  3.     Dim i&, j&
  4.     Dim lRow&
  5.     Dim bKind1 As Byte, bKind2 As Byte, strKind As String * 2
  6.     Dim t#
  7.     t = Timer
  8.     arr = Worksheets("订单排期").Range("a1").CurrentRegion
  9.     If Not IsArray(arr) Then Exit Sub
  10.     ReDim result(1 To (UBound(arr, 2) - 5) * (UBound(arr) - 1), 1 To 5)
  11.     For i = LBound(arr) + 1 To UBound(arr)
  12.         bKind1 = 0
  13.         For j = LBound(arr) + 5 To UBound(arr, 2)
  14.             
  15.             lRow = lRow + 1
  16.             result(lRow, 1) = arr(i, 3)
  17.             result(lRow, 2) = arr(i, 4)
  18.             If strKind <> Left(arr(1, j), 2) Then
  19.                 strKind = Left(arr(1, j), 2)
  20.                 bKind1 = bKind1 + 1
  21.                 bKind2 = 1
  22.             Else
  23.                 bKind2 = bKind2 + 1
  24.             End If
  25.             
  26.             result(lRow, 3) = bKind1 & arr(i, 2) & Format(bKind2, "00")
  27.             result(lRow, 4) = arr(1, j)
  28.             result(lRow, 5) = arr(i, j)
  29.         Next
  30.     Next
  31.     Application.ScreenUpdating = False
  32.     With Worksheets("单价编号")
  33.         .Range("a2").Resize(UBound(result), UBound(result, 2)) = result
  34.         .Range("a1").Resize(, 5) = Array("订单批号", "订单数量", "工序代码", "工序名称", "工序单价")
  35.         .Range("a1").CurrentRegion.EntireColumn.AutoFit
  36.     End With
  37.     Application.ScreenUpdating = True
  38. End Sub
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-4-21 14:41 | 显示全部楼层
格式就没有设置了，你可以自己调下。
回复

使用道具 举报

hwc2ycy
发表于 2013-4-21 14:53 | 显示全部楼层    本楼为最佳答案   
  1. Sub 转置数据()
  2.     Dim arr, result()
  3.     Dim i&, j&
  4.     Dim lRow&
  5.     Dim bKind1 As Byte, bKind2 As Byte, strKind As String * 2
  6.     Dim t#
  7.     t = Timer
  8.     arr = Worksheets("订单排期").Range("a1").CurrentRegion
  9.     If Not IsArray(arr) Then Exit Sub
  10.     ReDim result(1 To (UBound(arr, 2) - 5) * (UBound(arr) - 1), 1 To 5)
  11.     For i = LBound(arr) + 1 To UBound(arr)
  12.         bKind1 = 0
  13.         For j = LBound(arr) + 5 To UBound(arr, 2)
  14.             
  15.             lRow = lRow + 1
  16.             result(lRow, 1) = arr(i, 3)
  17.             result(lRow, 2) = arr(i, 4)
  18.             If strKind <> Left(arr(1, j), 2) Then
  19.                 strKind = Left(arr(1, j), 2)
  20.                 bKind1 = bKind1 + 1
  21.                 bKind2 = 1
  22.             Else
  23.                 bKind2 = bKind2 + 1
  24.             End If
  25.             
  26.             result(lRow, 3) = bKind1 & arr(i, 2) & Format(bKind2, "00")
  27.             result(lRow, 4) = arr(1, j)
  28.             result(lRow, 5) = arr(i, j)
  29.         Next
  30.     Next
  31.     Application.ScreenUpdating = False
  32.     With Worksheets("单价编号")
  33.         .Range("a2").Resize(UBound(result), UBound(result, 2)) = result
  34.         .Range("a1").Resize(, 5) = Array("订单批号", "订单数量", "工序代码", "工序名称", "工序单价")
  35.         With .Range("a1").CurrentRegion
  36.             .EntireColumn.AutoFit
  37.             .Borders.LineStyle = xlContinuous
  38.             .HorizontalAlignment = xlCenter
  39.         End With
  40.         i = .Cells(Rows.Count, 1).End(xlUp).Row
  41.         .Range("a2:e" & i).Font.Size = 10
  42.         .Range("d2:d" & i).Font.Bold = True
  43.         .Range("a2:b" & i).Font.ColorIndex = 53
  44.         .Range("d2:e" & i).Font.ColorIndex = 9
  45.     End With
  46.     Application.ScreenUpdating = True
  47.     MsgBox "转置完成"
  48. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-4-21 16:26 | 显示全部楼层
hwc2ycy 发表于 2013-4-21 14:53

高手就是高手!
我对这个问题48个小时都无从下手,向你学习!!
多谢了!!!
回复

使用道具 举报

hwc2ycy
发表于 2013-4-21 16:40 | 显示全部楼层
理清思路，就容易了。
回复

使用道具 举报

 楼主| 发表于 2013-4-21 17:00 | 显示全部楼层
hwc2ycy 发表于 2013-4-21 16:40
理清思路，就容易了。

老师我是初学VBA,能不能帮注释一下代码?
{:35:}{:912:}


回复

使用道具 举报

hwc2ycy
发表于 2013-4-21 21:50 | 显示全部楼层
森林木007 发表于 2013-4-21 17:00
老师我是初学VBA,能不能帮注释一下代码?
  1. Sub 转置数据()
  2. '源数组，结果数组
  3.     Dim arr, result()
  4.     Dim i&, j&
  5.     '数组记录行数
  6.     Dim lRow&
  7.     '工序序号1，工序序号2，工序类型
  8.     Dim bKind1 As Byte, bKind2 As Byte, strKind As String * 2
  9.     Dim t#
  10.     t = Timer
  11.     '读入源数据
  12.     arr = Worksheets("订单排期").Range("a1").CurrentRegion
  13.     '判断是否有数据读入
  14.     If Not IsArray(arr) Then Exit Sub

  16.     '重新定义结果数组大小：(25个工序）*（行数-1）
  17.     ReDim result(1 To (UBound(arr, 2) - 5) * (UBound(arr) - 1), 1 To 5)

  19.     '源数数据，行循环
  20.     For i = LBound(arr) + 1 To UBound(arr)
  21.         bKind1 = 0

  23.         '源数组，列循环
  24.         For j = LBound(arr) + 5 To UBound(arr, 2)
  25.             '每一列，都是新一行的开始
  26.             lRow = lRow + 1

  28.             result(lRow, 1) = arr(i, 3)    '订单批号
  29.             result(lRow, 2) = arr(i, 4)    '订单数量
  30.             If strKind <> Left(arr(1, j), 2) Then   '判断是否是新的工序
  31.                 strKind = Left(arr(1, j), 2)        '把新工序类型存入字符串中，
  32.                 bKind1 = bKind1 + 1                 '工序大序号
  33.                 bKind2 = 1                          '同一工序内的序号
  34.             Else
  35.                 bKind2 = bKind2 + 1                 '小序号加1
  36.             End If

  38.             '大序号 & 产品序号 & 小序号
  39.             result(lRow, 3) = bKind1 & arr(i, 2) & Format(bKind2, "00")
  40.             result(lRow, 4) = arr(1, j)         '工序名称
  41.             result(lRow, 5) = arr(i, j)         '工序单价
  42.         Next
  43.     Next

  45.     '关闭刷屏
  46.     Application.ScreenUpdating = False
  47.     With Worksheets("单价编号")
  48.         '写入结果数组到单元格中
  49.         .Range("a2").Resize(UBound(result), UBound(result, 2)) = result
  50.         '写入标题行
  51.         .Range("a1").Resize(, 5) = Array("订单批号", "订单数量", "工序代码", "工序名称", "工序单价")
  52.         With .Range("a1").CurrentRegion
  53.             '自动调整列宽
  54.             .EntireColumn.AutoFit
  55.             '实线边框
  56.             .Borders.LineStyle = xlContinuous
  57.             '水平居中
  58.             .HorizontalAlignment = xlCenter
  59.         End With

  61.         'A列最后一行数据所在行号
  62.         i = .Cells(Rows.Count, 1).End(xlUp).Row
  63.         '字体大小为10号
  64.         .Range("a2:e" & i).Font.Size = 10
  65.         'D列字体加粗
  66.         .Range("d2:d" & i).Font.Bold = True
  67.         'AB列字体颜色
  68.         .Range("a2:b" & i).Font.ColorIndex = 53
  69.         'DE列字体颜色
  70.         .Range("d2:e" & i).Font.ColorIndex = 9
  71.     End With
  72.     '打开刷屏
  73.     Application.ScreenUpdating = True
  74.     '显示对话框
  75.     MsgBox "转置完成"
  76. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
森林木007 + 1 很给力!

查看全部评分

回复

使用道具 举报

发表于 2013-4-21 22:15 | 显示全部楼层
高手就是高手。{:22:}
回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-19 21:43 , Processed in 0.324708 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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