[已解决]请教，如何实现批量，快速的转置。

小学生124 · 发表于 2017-5-2 13:51

请教，如何实现批量，快速的转置。如图所示：把黄色区域变成红色区域的格式

最佳答案

Excel学徒123

2017-5-2 16:16

小学生124 发表于 2017-5-2 16:15
哦，谢谢。我不会vba。只会点excel函数的皮毛，开始一直想怎么通过函数来实现，开始的思路是：b列有空格 ...

Option Explicit
Sub TransposeData()
Dim arrRst(), arrSrc
Dim Ends&, lrow&
Dim iCnt%, EpyCnt%
Dim strText$
Ends = Cells(Rows.Count, 1).End(3).Row + 1
arrSrc = Range("b3:b" & Ends).Value
For lrow = 1 To UBound(arrSrc)
If arrSrc(lrow, 1) <> "" Then
EpyCnt = EpyCnt + 1
iCnt = iCnt + 1
ReDim Preserve arrRst(1 To iCnt)
arrRst(iCnt) = ""
strText = strText & arrSrc(lrow, 1) & ","
Else
iCnt = iCnt + 1
ReDim Preserve arrRst(1 To iCnt)
arrRst(iCnt - EpyCnt) = Left(strText, Len(strText) - 1)
strText = ""
EpyCnt = 0
End If
Next
Range("c2").Resize(iCnt) = Application.Transpose(arrRst)
Range("c2:c" & iCnt + 1).TextToColumns Destination:=Range("c2"), Comma:=True, TrailingMinusNumbers:=True
End Sub

复制代码

不会自己就多花时间学，那要是没人帮你咋办呢，代码改了，拿去用吧

Excel学徒123 · 发表于 2017-5-2 14:20

用代码吧，估计会快点

小学生124 · 发表于 2017-5-2 14:27

Excel学徒123 发表于 2017-5-2 14:20
用代码吧，估计会快点

可以赐教下吗？谢谢。公司急的要，数据好多，我一个个转置要好久。可以教下吗。谢谢了

Excel学徒123 · 发表于 2017-5-2 15:35

小学生124 发表于 2017-5-2 14:27
可以赐教下吗？谢谢。公司急的要，数据好多，我一个个转置要好久。可以教下吗。谢谢了

附件都不准备好，谁愿意给你弄？？？？？

小学生124 · 发表于 2017-5-2 15:43

Excel学徒123 发表于 2017-5-2 15:35
附件都不准备好，谁愿意给你弄？？？？？

不好意思，是我疏忽了，谢谢你。麻烦您教下我，谢谢。

Excel学徒123 · 发表于 2017-5-2 15:56

本帖最后由 Excel学徒123 于 2017-5-2 15:58 编辑

小学生124 发表于 2017-5-2 15:43
不好意思，是我疏忽了，谢谢你。麻烦您教下我，谢谢。

Option Explicit
Sub TransposeData()
Dim arrRst(), arrSrc
Dim Ends&, lrow&
Dim iCnt%
Dim strText$
Ends = Cells(Rows.Count, 1).End(3).Row
arrSrc = Range("b3:b" & Ends).Value
For lrow = 1 To UBound(arrSrc)
If arrSrc(lrow, 1) <> "" Then
strText = strText & arrSrc(lrow, 1) & ","
Else
iCnt = iCnt + 1
ReDim Preserve arrRst(1 To iCnt)
arrRst(iCnt) = Left(strText, Len(strText) - 1)
strText = ""
End If
Next
Range("c2").Resize(iCnt) = Application.Transpose(arrRst)
Range("c2:c" & iCnt + 1).TextToColumns Destination:=Range("c2"), Comma:=True, TrailingMinusNumbers:=True
End Sub

复制代码

怎么用代码就不用教了哈

小学生124 · 发表于 2017-5-2 16:07

Excel学徒123 发表于 2017-5-2 15:56
怎么用代码就不用教了哈

恩，谢谢。大致就是这个意思，不过公司要求是每条转置记录对应到每条记录的空白处。如图所示（因为前面有分店的名称，要对应每分店）。请问下怎么实现

Excel学徒123 · 发表于 2017-5-2 16:08

自己再调了不能干等答案

小学生124 · 发表于 2017-5-2 16:15

Excel学徒123 发表于 2017-5-2 16:08
自己再调了不能干等答案

哦，谢谢。我不会vba。只会点excel函数的皮毛，开始一直想怎么通过函数来实现，开始的思路是：b列有空格就显示数据，显示几条数据根据相对应a列的数字来确定。结果显示在c列往后。尝试了offset，match，vlookup，这些查找函数，都实现不了。所以在网上发帖，向高手请教。

Excel学徒123 · 发表于 2017-5-2 16:16

小学生124 发表于 2017-5-2 16:15
哦，谢谢。我不会vba。只会点excel函数的皮毛，开始一直想怎么通过函数来实现，开始的思路是：b列有空格 ...

Option Explicit
Sub TransposeData()
Dim arrRst(), arrSrc
Dim Ends&, lrow&
Dim iCnt%, EpyCnt%
Dim strText$
Ends = Cells(Rows.Count, 1).End(3).Row + 1
arrSrc = Range("b3:b" & Ends).Value
For lrow = 1 To UBound(arrSrc)
If arrSrc(lrow, 1) <> "" Then
EpyCnt = EpyCnt + 1
iCnt = iCnt + 1
ReDim Preserve arrRst(1 To iCnt)
arrRst(iCnt) = ""
strText = strText & arrSrc(lrow, 1) & ","
Else
iCnt = iCnt + 1
ReDim Preserve arrRst(1 To iCnt)
arrRst(iCnt - EpyCnt) = Left(strText, Len(strText) - 1)
strText = ""
EpyCnt = 0
End If
Next
Range("c2").Resize(iCnt) = Application.Transpose(arrRst)
Range("c2:c" & iCnt + 1).TextToColumns Destination:=Range("c2"), Comma:=True, TrailingMinusNumbers:=True
End Sub

复制代码

不会自己就多花时间学，那要是没人帮你咋办呢，代码改了，拿去用吧

		自动登录	找回密码
密码			注册