Microsoft Excel - excel vba - Asked By sql rocks on 18-Aug-11 02:22 PM

I have data in 3 columns of excel like-
Column A  Column B  Column C
a;b;c        orange    fruit
d           carrot      veggie
e;f          apple      fruit

I want an excel vba subroutine that would arrange the data like this-
Column A  Column B  Column C
a          orange    fruit
b          orange    fruit
c          orange    fruit
d          carrot      veggie
e          apple       fruit

Any help is greatly appreciated!!
Thank you in advance.

wally eye replied to sql rocks on 18-Aug-11 03:00 PM

This will do it for you:

Public Sub btnUpdate_Click()

Call ParseRange(Worksheets("Sheet1").Range("A1:C1"), Worksheets("Sheet1").Range("e1"))

End Sub

Public Sub ParseRange(ByVal Target As Excel.Range, ByVal Dest As Excel.Range)

Dim arrDataIn As Variant
Dim arrDataOut() As Variant

    Dim lngRowCount         As Long
    Dim lngCurrRow          As Long
    Dim intLastPos          As Integer
    Dim intPos            As Integer
    Dim intCol            As Integer

    lngRowCount = Target.Parent.Columns(Target.Column).Find(What:="*", After:=Cells(1, Target.Column), _
      SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    arrDataIn = Target.Resize(lngRowCount - Target.Row + 1, Target.Columns.Count)

    ReDim arrDataOut(1 To UBound(arrDataIn, 2), 1 To 1)
    lngRowCount = 0
    For lngCurrRow = LBound(arrDataOut) To UBound(arrDataOut)
      intLastPos = 0
      Do
        intPos = InStr(intLastPos + 1, arrDataIn(lngCurrRow, 1), ",")
        If intPos = 0 Then
          intPos = 32767
        End If
        lngRowCount = lngRowCount + 1
        ReDim Preserve arrDataOut(1 To UBound(arrDataIn, 2), 1 To lngRowCount)
        arrDataOut(1, lngRowCount) = Mid(arrDataIn(lngCurrRow, 1), intLastPos + 1, intPos - intLastPos - 1)
        For intCol = 2 To UBound(arrDataIn, 2)
          arrDataOut(intCol, lngRowCount) = arrDataIn(lngCurrRow, intCol)
        Next intCol
        intLastPos = intPos
      Loop While intPos > 0 And intPos < 32767
    Next lngCurrRow

    If Dest.Value > "" Then
      lngRowCount = Dest.Parent.Columns(Dest.Column).Find(What:="*", After:=Cells(1, Dest.Column), _
        SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
      Dest.Resize(lngRowCount - Dest.Row + 1, Target.Columns.Count).ClearContents
    End If
    Dest.Resize(UBound(arrDataOut, 2), UBound(arrDataOut)) = Application.Transpose(arrDataOut)

End Sub

You will need to change the ParseRange call to match your spreadsheet. The first parameter is the top row of your input data, the second parameter is the location you would like the data to be placed. It will automatically grab all of the rows below the target columns. If there is data in the destination it will clear it out prior to putting the results in. This will accept more than just the three columns, if you want to expand it out, just change the first parameter on the call to match what you need.

sql rocks replied to wally eye on 18-Aug-11 03:13 PM

Thank you wally eye, worked liked a charm!!!!

sql rocks replied to wally eye on 18-Aug-11 03:52 PM

Wally eye,

if I want to have a little variation and have it look it below, how can i do it....?

Column A    Column B
orange        fruit
   a           fruit
   b           fruit
   c           fruit
carrot      veggie
  d        veggie
  apple        fruit
  e          fruit
  f           fruit

wally eye replied to sql rocks on 18-Aug-11 05:21 PM

Just about the same:

Public Sub ParseRange2(ByVal Target As Excel.Range, ByVal Dest As Excel.Range)

Dim arrDataIn As Variant

Dim arrDataOut() As Variant

Dim lngRowCount As Long

Dim lngCurrRow As Long

Dim intLastPos As Integer

Dim intPos As Integer

' Dim intCol As Integer

lngRowCount = Target.Parent.Columns(Target.Column).Find(What:="*", After:=Cells(1, Target.Column), _

SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

arrDataIn = Target.Resize(lngRowCount - Target.Row + 1, Target.Columns.Count)

ReDim arrDataOut(1 To 2, 1 To 1)

lngRowCount = 0

For lngCurrRow = LBound(arrDataIn) To UBound(arrDataIn)

intLastPos = 0

lngRowCount = lngRowCount + 1

ReDim Preserve arrDataOut(1 To 2, 1 To lngRowCount)

arrDataOut(1, lngRowCount) = arrDataIn(lngCurrRow, 2)

arrDataOut(2, lngRowCount) = arrDataIn(lngCurrRow, 3)

Do

intPos = InStr(intLastPos + 1, arrDataIn(lngCurrRow, 1), ",")

If intPos = 0 Then

intPos = 32767

End If

lngRowCount = lngRowCount + 1

ReDim Preserve arrDataOut(1 To 2, 1 To lngRowCount)

arrDataOut(1, lngRowCount) = Mid(arrDataIn(lngCurrRow, 1), intLastPos + 1, intPos - intLastPos - 1)

arrDataOut(2, lngRowCount) = arrDataIn(lngCurrRow, 3)

intLastPos = intPos

Loop While intPos > 0 And intPos < 32767

Next lngCurrRow

If Dest.Value > "" Then

lngRowCount = Dest.Parent.Columns(Dest.Column).Find(What:="*", After:=Cells(1, Dest.Column), _

SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

Dest.Resize(lngRowCount - Dest.Row + 1, Target.Columns.Count).ClearContents

End If

Dest.Resize(UBound(arrDataOut, 2), UBound(arrDataOut)) = Application.Transpose(arrDataOut)

End Sub

I just added a block to make the header column and tweaked it to output two columns. While I was changing this, though, I noticed an error in my earlier version. There is a line in there that reads:

for lngcurrrow = lbound(arrdataout) to ubound(arrdataout)

it should read

for lngcurrrow = lbound(arrdatain) to ubound(arrdatain)

it worked in my testing because it was a three by three array, but that was just a coincidence...

sql rocks replied to wally eye on 19-Aug-11 01:10 PM

Thank you!!!! It is working now:)))

Really appreciate your help!!!!

sql rocks replied to wally eye on 20-Oct-11 03:10 PM

It has being long time now, and i got one error yesterday = Application defined or object-denfined error
whenlngRowCount = 1

do you have any suggestion on how to overcome this?

wally eye replied to sql rocks on 20-Oct-11 10:06 PM

I suspect it is a data issue, but we can try. I've tweaked the code a bit, and put some error trapping in:

Public Sub ParseRange2(ByVal Target As Excel.Range, ByVal Dest As Excel.Range)
On Error GoTo Proc_Error

Dim arrDataIn       As Variant
Dim arrDataOut()      As Variant

Dim lngRowCount     As Long
Dim lngCurrRow      As Long
Dim intLastPos      As Integer
Dim intPos        As Integer

lngRowCount = Target.Parent.Columns(Target.Column).Find(What:="*", After:=Cells(1, Target.Column), _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
arrDataIn = Target.Resize(lngRowCount - Target.Row + 1, Target.Columns.Count)

ReDim arrDataOut(1 To 2, 1 To 1)
lngRowCount = 0
For lngCurrRow = LBound(arrDataIn) To UBound(arrDataIn)
    intLastPos = 0
    lngRowCount = lngRowCount + 1
    ReDim Preserve arrDataOut(1 To 2, 1 To lngRowCount)
    arrDataOut(1, lngRowCount) = arrDataIn(lngCurrRow, 2)
    arrDataOut(2, lngRowCount) = arrDataIn(lngCurrRow, 3)
    intPos = InStr(1, arrDataIn(lngCurrRow, 1), ";")
    Do While intPos > 0
    lngRowCount = lngRowCount + 1
    ReDim Preserve arrDataOut(1 To 2, 1 To lngRowCount)
    arrDataOut(1, lngRowCount) = Mid(arrDataIn(lngCurrRow, 1), intLastPos + 1, intPos - intLastPos - 1)
    arrDataOut(2, lngRowCount) = arrDataIn(lngCurrRow, 3)
    intLastPos = intPos
    intPos = InStr(intPos + 1, arrDataIn(lngCurrRow, 1), ";")
    Loop
    lngRowCount = lngRowCount + 1
    ReDim Preserve arrDataOut(1 To 2, 1 To lngRowCount)
    arrDataOut(1, lngRowCount) = Mid(arrDataIn(lngCurrRow, 1), intLastPos + 1)
    arrDataOut(2, lngRowCount) = arrDataIn(lngCurrRow, 3)
Next lngCurrRow

If Dest.Value > "" Then
    lngRowCount = Dest.Parent.Columns(Dest.Column).Find(What:="*", After:=Cells(1, Dest.Column), _
    SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

End If
Dest.Resize(UBound(arrDataOut, 2), UBound(arrDataOut)) = Application.Transpose(arrDataOut)

Proc_Exit:

Exit Sub

Proc_Error:

    Select Case Err
      Case Else
        MsgBox "Error " & CStr(Err) & ": " & Err.Description
        Resume ' Proc_Exit
    End Select

Exit Sub

End Sub

Note that at the bottom there is a Resume ' Proc_Exit. I've commented out the Proc_Exit, when this is fixed you will want to uncomment it.

Run this with the same parameters as before, if it errors as well it will pop up a message box with the error number and description. If it does, press ctrl-break and it should be highlighting the Resume line. Press F8 and it will return to the line that caused the error. Hover over each variable and record the value shown. If you can, send me a copy or a dummied copy of the data it errors out on, and the variable values.