excel部分内容横排变竖排（二维转一维）

陆地鱼仙人掌

数据源如表1，一个营销员可以有多个片区编号（也可以没有片区编号），片区编号7后面可能还有片区编号9……等编号，现需要把片区编号变成竖着放在编号这一列中，营销员有多少个片区编号，就出现多少列（当营销员没有片区编号时，出现1列，编号留空），效果如表2。excel表格文件详见附件。
。
数据源：表1：

营销员工号

营销员姓名

营销中心

区域

营销中心编号

入职时间

所属主任工号

所属主任姓名

片区编号1

片区编号2

片区编号3

片区编号4

片区编号5

片区编号6

片区编号7

YX0001

张三

广州

白云区

11

2017/1/20

ZR102

李南

1

5

107

23

YX1020

李四

广州

天河区

11

2018/1/9

ZR2008

李师

45

33

YX20012

旺达

广州

海珠区

11

2014/2/1

ZR1102

韩丽

78

SH0281

清风

上海

浦东区

35

2017/6/21

DJ2001

牡丹

5

21

30

17

41

8003

SH0301

玫瑰

上海

静安区

35

2018/9/2

DJ3089

杜鹃

效果：表2：

营销员工号	营销员姓名	营销中心	区域	营销中心编号	入职时间	所属主任工号	所属主任姓名	片区编号
YX0001	张三	广州	白云区	11	2017/1/20	ZR102	李南	1
YX0001	张三	广州	白云区	11	2017/1/20	ZR102	李南	5
YX0001	张三	广州	白云区	11	2017/1/20	ZR102	李南	107
YX0001	张三	广州	白云区	11	2017/1/20	ZR102	李南	23
YX1020	李四	广州	天河区	11	2018/1/9	ZR2008	李师	45
YX1020	李四	广州	天河区	11	2018/1/9	ZR2008	李师	33
YX20012	旺达	广州	海珠区	11	2014/2/1	ZR1102	韩丽	78
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	5
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	21
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	30
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	17
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	41
SH0281	清风	上海	浦东区	35	2017/6/21	DJ2001	牡丹	8003
SH0301	玫瑰	上海	静安区	35	2018/9/2	DJ3089	杜鹃

liulang0808

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
4.     arr = Sheets(1).UsedRange
   
5.     a = 2
   
6.     For j = 2 To UBound(arr)
   
7.         For x = 1 To 8
   
8.             Cells(a, x) = arr(j, x)
   
9.         Next x
   
10.         For i = 9 To UBound(arr, 2)
    
11.             If Len(arr(j, i)) > 0 Then
    
12.                 For x = 1 To 8
    
13.                     Cells(a, x) = arr(j, x)
    
14.                 Next x
    
15.                 Cells(a, 9) = arr(j, i)
    
16.                 a = a + 1
    
17.             End If
    
18.         Next i
    
19.     Next j
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

liulang0808

附件内容供参考。。。。。。

cjc209

我是用的通用型的装置 人机对话形 按操作操作 动动鼠标 输入该输入的数字就行 非常灵活

1. Sub 二维转一维()
   
2. Dim i%, arr, crr
   
3. arr = Application.InputBox("选择区域", Type:=8)
   
4. Set tishi = Application.InputBox("选择存放起始单元格", Type:=8)
   
5. t1 = UBound(arr)
   
6. t2 = UBound(arr, 2)
   
7. qsl = Val(InputBox("请输入装置的起始列（以区域为参照物）：", "拆分表格", "1"))
   
8. bb = MsgBox("选择： 是 为忽略空值  否 为允许空值存在", vbYesNo)
   
9. Application.ScreenUpdating = False
   
10. Application.DisplayAlerts = False
    
11. ReDim brr(1 To t1 * t2, 1 To 3 + qsl - 1)
    
12. If bb = 6 Then
    
13. For i = 2 To t1
    
14.     m = 1 + qsl
    
15.     For k = i To i + t2 - 2
    
16.     If arr(i, m) <> "" And arr(i, 1) <> "" Then
    
17.         n = n + 1
    
18.         brr(n, 1) = arr(i, qsl)
    
19.         brr(n, 2) = arr(1, m)
    
20.         brr(n, 3) = arr(i, m)
    
21.     If qsl > 1 Then
    
22.       For ls = 1 To qsl - 1
    
23.         If ls <= qsl - 1 Then
    
24.          tishi.Offset(n, ls - 1) = arr(i, ls)
    
25.         End If
    
26.       Next
    
27.       ls = 0
    
28.      End If
    
29.     End If
    
30.         m = m + 1
    
31.         If m > t2 Then GoTo 1
    
32.     Next k
    
33. 1:
    
34. Next i
    
35. Else
    
36. For i = 2 To t1
    
37.     m = 1 + qsl
    
38.     For k = i To i + t2 - 2
    
39.     If arr(i, 1) <> "" Then
    
40.         n = n + 1
    
41.        brr(n, 1) = arr(i, qsl)
    
42.         brr(n, 2) = arr(1, m)
    
43.         brr(n, 3) = arr(i, m)
    
44.     If qsl > 1 Then
    
45.       For ls = 1 To qsl - 1
    
46.         If ls <= qsl - 1 Then
    
47.          tishi.Offset(n, ls - 1) = arr(i, ls)
    
48.         End If
    
49.       Next
    
50.       ls = 0
    
51.      End If
    
52.     End If
    
53.       m = m + 1
    
54.     If m > t2 Then GoTo 2
    
55.     Next k
    
56. 2:
    
57. Next i
    
58. End If
    
59. For l = 1 To qsl
    
60. tishi.Offset(, l - 1) = arr(1, l)
    
61. Next
    
62.   tishi.Offset(1, qsl - 1).Resize(UBound(brr), 3 + qsl - 1) = brr
    
63.   Application.DisplayAlerts = True
    
64. Application.ScreenUpdating = True
    
65.     MsgBox "转置完毕！"
    
66. End Sub
    

复制代码

陆地鱼仙人掌

liulang0808 发表于 2018-9-24 08:27

可否加上注释？

陆地鱼仙人掌

cjc209 发表于 2018-9-24 10:05
我是用的通用型的装置 人机对话形 按操作操作 动动鼠标 输入该输入的数字就行 非常灵活

这几个要选择的区域怎么选？有什么讲究？
arr = Application.InputBox("选择区域", Type:=8)
Set tishi = Application.InputBox("选择存放起始单元格", Type:=8)
t1 = UBound(arr)
t2 = UBound(arr, 2)
qsl = Val(InputBox("请输入装置的起始列（以区域为参照物）：", "拆分表格", "1"))
bb = MsgBox("选择： 是 为忽略空值  否 为允许空值存在", vbYesNo)

陆地鱼仙人掌

liulang0808 发表于 2018-9-24 08:27

如果要把转换后的内容在转换为转换前的，即表2转换成表1，要怎么写代码？

liulang0808

陆地鱼仙人掌 发表于 2018-9-24 21:44
如果要把转换后的内容在转换为转换前的，即表2转换成表1，要怎么写代码？

论坛上有很多案例，楼主可以自行搜索看看吧