Excel VBA：转置string的不同部分

我有相邻的单元格中的水平值。 在每个单元格中，我正在提取单元格的某个子string，并且想要在某些列中垂直转置每个部分。

例：

ColA ColB ColC First.Second<Third> Fourth.Fifth<Sixth> Seventh.Eighth<Ninth> 

应该看起来像一个新的工作表（WS2）：

  ColA ColB ColC First Second Third Fourth Fifth Sixth Seventh Eighth Ninth 

我试着循环遍历行和列，但随机跳过

 For i = 2 to lastRow lastCol = ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column For j = 2 to lastCol cellVal = ws.Cells(i, j).Value firstVal = Split(cellVal, ".") secondVal = 'extract second val thirdVal = 'extract third val ws2.Cells(i,1).Value = firstVal ws2.Cells(i,2).Value = secondVal ws3.Cells(i,4).Value = thirdVal 

编辑：更新几乎工作的代码如下：

 Sub transPose() Dim used As Range Set used = Sheet1.UsedRange 'make better constraint if necessary Dim cell As Range Dim arr(0 To 3) As String Dim str As String Dim pointStr As Variant, arrowSplit As Variant Dim rowCount As Long rowCount = 0 For Each cell In used 'This goes across rows and then down columns str = Trim(cell.Value2) If str <> "" Then 'Use better qualification if necessary spaceStr = Split(str, " ") arr(0) = spaceStr(0) arr(1) = spaceStr(1) arrowSplit = Split(spaceStr(1), "<") arr(2) = LCase(Mid(str, Application.Find("<", str) + 1, 1)) & LCase(arrowSplit(0)) openEmail = InStr(str, "<") closeEmail = InStr(str, ">") arr(3) = Mid(str, openEmail + 1, closeEmail - openEmail - 1) rowCount = rowCount + 1 Sheet2.Cells(1 + rowCount, 1).Resize(1, 4).Value = arr End If Next cell End Sub 

EDIT2：数据实际上看起来像

  ColA ColB etc... John Smith<[e-mail]> Jane Doe<[e-mail]> 

而应该看起来像：

 ColA ColB ColC ColD John Smith jsmith [e-mail] Jane Doe jdoe [e-mail] 

Answer 1

尝试这个：

 Sub transPose() Dim used As Range Set used = Sheet1.UsedRange 'make better constraint if necessary Dim cell As Range Dim arr(0 To 2) As String Dim str As String Dim pointStr As Variant, arrowSplit As Variant Dim rowCount As Long rowCount = 0 For Each cell In used 'This goes across rows and then down columns str = cell.Value2 If str <> "" Then 'Use better qualification if necessary pointStr = Split(str, ".") arr(0) = pointStr(0) arrowSplit = Split(pointStr(1), "<") arr(1) = arrowSplit(0) arr(2) = Split(arrowSplit(1), ">")(0) rowCount = rowCount + 1 Sheet2.Cells(1 + rowCount, 1).Resize(1, 3).Value = arr End If Next cell End Sub 

Answer 2

对于每个input行，您将有3个输出行，这意味着您为每个input行将输出行增加3。 此外，单元格function需要（行，列）参数。

math变得愚蠢，如果你迭代i和j从开始行/ col到最后一行/ col，所以我build议改为迭代行数/列数，并使用起始点作为参考，要么存储为Range对象或起始行/列。

 For i = 0 to ws.Rows.Count For j = 0 to ws.Columns.Count cellVal = ws.Cells(i + startRow, j + startCol).Value firstVal = Split(cellVal, ".") secondVal = 'extract second val thirdVal = 'extract third val ws2.Cells((i*3) + startRow, j + startCol).Value = firstVal ws2.Cells((i*3) + 1 + startRow, j + startCol).Value = secondVal ws3.Cells((i*3) + 2 + startRow, j + startCol).Value = thirdVal 

等等…

事实上，如果我这样做，我可能只是做function的inputRange和outputRange参数，然后只是遍历这些。 这将简化迭代（不需要混乱的startRow或startCol）和索引。 如果您正在寻找这样的解决scheme，请发表评论，我可以添加它。

Answer 3

在OP编辑的问题后编辑

你可以试试这个：

 Sub main2() Dim cell As Range, row As Range Dim arr As Variant Dim finalValues(1 To 4) As String Dim iRow As Long Dim ws As Worksheet, ws2 As Worksheet Set ws = Worksheets("originalData") '<--| change "originalData" to your actual sheet name with starting data Set ws2 = Worksheets("results") '<--| change "results" to your actual sheet name with starting data For Each row In ws.UsedRange.Rows For Each cell In row.SpecialCells(xlCellTypeConstants) arr = Split(Replace(Replace(cell.Value, "<", " "), ">", ""), " ") finalValues(1) = arr(0): finalValues(2) = arr(1): finalValues(3) = Left(arr(0), 1) & arr(1): finalValues(4) = arr(2) iRow = iRow + 1 ws2.Cells(iRow, 1).Resize(, UBound(finalValues)).Value = finalValues Next Next End Sub