CODEWITHSUNDEEP
vbaexcel
MJ95
MJ95

Reputation: 479

Excel VBA: Transpose different parts of a string

I have values that are horizontally in cells next to each other. In each cell, I'm extracting a certain substring of the cell and want to transpose each part vertically in certain columns.

Example:

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

Should look like on a new worksheet (ws2):

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

I tried looping over rows and columns, but that skipped randomly

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

EDIT: Updated almost working code below:

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: Data actually looks like

           ColA                                  ColB                    etc...
  John Smith<[email protected]>         Jane Doe<[email protected]>

And Should look like:

ColA     ColB      ColC           ColD
John     Smith    jsmith     [email protected]
Jane     Doe      jdoe       [email protected]

Upvotes: 1

Views: 481

Answers (3)

user3598756
user3598756

Reputation: 29421

edited after OP's edited question

you could try this:

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

Upvotes: 0

MacroMarc
MacroMarc

Reputation: 3324

Try this:

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

Upvotes: 2

Blackhawk
Blackhawk

Reputation: 6140

For each input row, you will have 3 output rows, meaning you increment the output row by 3 for each input row. Additionally, the Cells function takes (row, col) parameters.

The math becomes goofy if you're iterating i and j from the start row/col to the last row/col, so I suggest instead iterating over the count of rows/cols and using a starting point for reference, either a cell stored as a Range object or the start row/col.

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

Etc...

In fact, if I were doing this, I would probably just make inputRange and outputRange parameters of the function and then just iterate through those. It would simplify both the iteration (no need for the messy startRow or startCol) and the indexing. If you are looking for that sort of solution, drop a comment and I can add it.

Upvotes: 1

Related Questions