设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 2列数据相同类拆分成50列
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
返回列表 发新帖
查看: 1113|回复: 8

[求助] 2列数据相同类拆分成50列

[复制链接]
jd23qq

TA的精华主题

TA的得分主题
发表于 2018-9-7 14:03 | 显示全部楼层 |阅读模式
[广告] ★ ReportLite:表哥表姐早下班神器，专治各种报表不服，拒绝无意义的重复劳动 ★
类型数据EF..为结果类型
数据1
数据2
数据3
数据4
数据5
数据6
数据7
数据8
数据9
数据10
数据11
数据12
数据13
数据14
数据15
数据16
数据17
数据18
数据19
数据20
数据21
数据22
数据23
look=101look=10
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
look=102look=10
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
look=103look=20
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
look=104look=20
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
look=105look=20
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
look=106look=30
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
look=107look=30
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
look=108look=30
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
look=109
look=1010
look=1011
look=1012

数据, 相同, 同类, 拆分, 分成
TIM截图20180907140222.jpg

2列数据相同类拆分成50列.zip

368.52 KB, 下载次数: 6
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-7 14:42 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
  1. Sub test1()
  2.     Application.ScreenUpdating = False
  3.     arr = [a1].CurrentRegion
  4.     a = 1
  5.     With Sheets(2)
  6.         For j = 2 To UBound(arr)
  7.             If arr(j, 2) Mod 50 = 0 Then
  8.                 .Cells(a, 51) = arr(j, 2)
  9.                 .Cells(a, 1) = arr(j, 1)
  10.             Else
  11.                 If arr(j, 2) Mod 50 = 1 Then
  12.                     a = a + 1
  13.                     .Cells(a, 2) = arr(j, 2)
  14.                     .Cells(a, 1) = arr(j, 1)
  15.                 End If
  16.                 .Cells(a, arr(j, 2) Mod 50 + 1) = arr(j, 2)
  17.             End If
  18.         Next j
  19.     End With
  20.     Application.ScreenUpdating = True
  21. End Sub
复制代码
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-7 14:44 | 显示全部楼层
[广告] ★ ReportLite:表哥表姐早下班神器，专治各种报表不服，拒绝无意义的重复劳动 ★
附件内容供参考。。。。

10万行2列数据相同类拆分成50列.zip

482.74 KB, 下载次数: 12
回复

举报

jd23qq

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-9-7 16:41 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
liulang0808 发表于 2018-9-7 14:44
附件内容供参考。。。。

谢谢，高手的回复只能得到1行数据，重新上传数据样品，请帮忙测试一下
12.jpg

10万行2列数据相同类拆分成50列2.zip

510.1 KB, 下载次数: 3
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-7 18:15 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
jd23qq 发表于 2018-9-7 16:41
谢谢，高手的回复只能得到1行数据，重新上传数据样品，请帮忙测试一下

3楼附件是针对楼主之前的值，现在B列内容有变化
回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-7 18:26 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
  1. Sub test1()
  2.     Application.ScreenUpdating = False
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = [a1].CurrentRegion
  5.     a = 1
  6.     With Sheets(2)
  7.         For j = 2 To UBound(arr)
  8.             d(arr(j, 1)) = 1 + d(arr(j, 1))
  9.             m = d(arr(j, 1))
  10.             If m Mod 50 = 0 Then
  11.                 .Cells(a, 51) = arr(j, 2)
  12.                 .Cells(a, 1) = arr(j, 1)
  13.             Else
  14.                 If m Mod 50 = 1 Then
  15.                     a = a + 1
  16.                     .Cells(a, 2) = arr(j, 2)
  17.                     .Cells(a, 1) = arr(j, 1)
  18.                 End If
  19.                 .Cells(a, m Mod 50 + 1) = arr(j, 2)
  20.             End If
  21.         Next j
  22.     End With
  23.     Application.ScreenUpdating = True
  24. End Sub
复制代码

评分

1

查看全部评分

回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2018-9-7 18:26 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
  1. Sub test()
  2.   Dim r&, i&
  3.   Dim arr, brr
  4.   With Worksheets("sheet1")
  5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  6.     arr = .Range("a2:b" & r)
  7.     ReDim brr(1 To UBound(arr), 1 To 51)
  8.     xm = ""
  9.     m = 0
  10.     For i = 1 To UBound(arr)
  11.       If arr(i, 1) <> xm Then
  12.         m = m + 1
  13.         brr(m, 1) = arr(i, 1)
  14.         brr(m, 2) = arr(i, 2)
  15.         xm = arr(i, 1)
  16.         n = 2
  17.       Else
  18.         n = n + 1
  19.         If n > 51 Then
  20.           m = m + 1
  21.           brr(m, 1) = arr(i, 1)
  22.           brr(m, 2) = arr(i, 2)
  23.           n = 2
  24.         Else
  25.           brr(m, n) = arr(i, 2)
  26.         End If
  27.       End If
  28.     Next
  29.   End With
  30.   With Worksheets("sheet4")
  31.     .UsedRange.Offset(1, 0).Clear
  32.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
  33.   End With
  34. End Sub
复制代码

评分

1

查看全部评分

回复

举报

liulang0808

TA的精华主题

TA的得分主题
发表于 2018-9-7 18:27 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
附件内容供参考

10万行2列数据相同类拆分成50列2.zip

745.59 KB, 下载次数: 3
回复

举报

chxw68

TA的精华主题

TA的得分主题
发表于 2018-9-7 18:27 | 显示全部楼层
[广告] ★ ReportLite:表哥表姐早下班神器，专治各种报表不服，拒绝无意义的重复劳动 ★
练练手。。

10万行2列数据相同类拆分成50列2.rar

713.53 KB, 下载次数: 3
回复

举报

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

本版积分规则

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

GMT+8, 2025-1-13 17:34 , Processed in 0.029439 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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