|
请教,如何实现批量,快速的转置。如图所示:把黄色区域变成红色区域的格式
- 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
复制代码不会自己就多花时间学,那要是没人帮你咋办呢,代码改了,拿去用吧
|
|