vba - Excel VBA : Transpose different parts of a string

Question

我的值在彼此相邻的单元格中水平排列。在每个单元格中，我正在提取单元格的某个子字符串，并希望在某些列中垂直转置每个部分。

例子:

    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<John.Smith@google.com>         Jane Doe<Jane.Doe@google.com>

应该看起来像:

ColA     ColB      ColC           ColD
John     Smith    jsmith     john.smith@google.com
Jane     Doe      jdoe       jane.doe@google.com

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