Unable to create macro due to varying data

**theatricalveggie** · 02-23-2011, 02:53 PM

If anyone could help me with this, I would be very appreciative! I'm trying to figure out a macro to rearrange some data, however, it varies from item to item so I am unable to simply use text to columns or a cell offset to do the rearranging. I have attached an example for your review. Please let me know if I can provide any additional information.

**pike** · 02-24-2011, 05:55 AM

Hi theatricalveggie

Welcome to the forum

Option Explicit
Sub ptest()
    Dim a, b(), i As Long, n As Long
    a = Range("A3:C19").Value" or 
   '  With Sheets(1).Range("a1").CurrentRegion
     '   a = .Resize(, 5).Value
     '    End With
  '  ReDim b(1 To UBound(a, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For i = LBound(a, 1) To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                .Add a(i, 1), n
            End If
            Select Case a(i, 2)
            Case "Fruit"
                b(.Item(a(i, 1)), 2) = a(i, 3)
            Case "Brand"
                b(.Item(a(i, 1)), 4) = a(i, 3)
            Case "Color"
                b(.Item(a(i, 1)), 5) = a(i, 3)
            Case Else
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", " , ", "") & a(i, 3)
            End Select
        Next
    End With
    Range("F1").Resize(1, 5).Value = Array("Number", "Fruit", "Value", "Brand", "Color")
    Range("F2").Resize(n, 5).Value = b
End Sub

**theatricalveggie** · 02-24-2011, 11:23 AM

Thank you so much!

Question though: I copied and pasted this into VBA as is on my example sheet, and I received a Syntax error. Do you know how to resolve this issue?

Thanks!

Originally Posted by pike

Hi theatricalveggie

Welcome to the forum

Option Explicit
Sub ptest()
    Dim a, b(), i As Long, n As Long
    a = Range("A3:C19").Value" or 
   '  With Sheets(1).Range("a1").CurrentRegion
     '   a = .Resize(, 5).Value
     '    End With
  '  ReDim b(1 To UBound(a, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For i = LBound(a, 1) To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                .Add a(i, 1), n
            End If
            Select Case a(i, 2)
            Case "Fruit"
                b(.Item(a(i, 1)), 2) = a(i, 3)
            Case "Brand"
                b(.Item(a(i, 1)), 4) = a(i, 3)
            Case "Color"
                b(.Item(a(i, 1)), 5) = a(i, 3)
            Case Else
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", " , ", "") & a(i, 3)
            End Select
        Next
    End With
    Range("F1").Resize(1, 5).Value = Array("Number", "Fruit", "Value", "Brand", "Color")
    Range("F2").Resize(n, 5).Value = b
End Sub

**pike** · 02-24-2011, 09:26 PM

one little type-0.. tested this one

Option Explicit
Sub ptest()
    Dim a, b(), i As Long, n As Long
    a = Sheets(1).Range("A3:C19").Value '" or
   '  With Sheets(1).Range("a1").CurrentRegion
     '   a = .Resize(, 5).Value
     '    End With
    ReDim b(1 To UBound(a, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For i = LBound(a, 1) To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                .Add a(i, 1), n
            End If
            Select Case a(i, 2)
            Case "Fruit"
                b(.Item(a(i, 1)), 2) = a(i, 3)
            Case "Brand"
                b(.Item(a(i, 1)), 4) = a(i, 3)
            Case "Color"
                b(.Item(a(i, 1)), 5) = a(i, 3)
            Case Else
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", " , ", "") & a(i, 3)
            End Select
        Next
    End With
    Sheets(1).Range("F1").Resize(1, 5).Value = Array("Number", "Fruit", "Value", "Brand", "Color")
   Sheets(1).Range("F2").Resize(n, 5).Value = b
End Sub

**theatricalveggie** · 03-04-2011, 04:17 PM

This is sooo close to what I need. When I ran the macro, I got:

Number Fruit Value Brand Color
1 Banana Trader Joe's Chiquita Yellow
2 Banana 3 oz Chiquita Green
3 Apple New Hampshire Washington Green
4 Apple Whole Foods , 5 oz Fuji Red

However, I need to keep the values in a separate row, as they are in the example.

Again, I can't tell you how much I appreciate the help. I cannot figure out how to get the values in their own rows....

Originally Posted by pike

one little type-0.. tested this one

Option Explicit
Sub ptest()
    Dim a, b(), i As Long, n As Long
    a = Sheets(1).Range("A3:C19").Value '" or
   '  With Sheets(1).Range("a1").CurrentRegion
     '   a = .Resize(, 5).Value
     '    End With
    ReDim b(1 To UBound(a, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For i = LBound(a, 1) To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                .Add a(i, 1), n
            End If
            Select Case a(i, 2)
            Case "Fruit"
                b(.Item(a(i, 1)), 2) = a(i, 3)
            Case "Brand"
                b(.Item(a(i, 1)), 4) = a(i, 3)
            Case "Color"
                b(.Item(a(i, 1)), 5) = a(i, 3)
            Case Else
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", " , ", "") & a(i, 3)
            End Select
        Next
    End With
    Sheets(1).Range("F1").Resize(1, 5).Value = Array("Number", "Fruit", "Value", "Brand", "Color")
   Sheets(1).Range("F2").Resize(n, 5).Value = b
End Sub

**pike** · 03-11-2011, 01:51 AM

Hi theatricalveggie,
Apologies on the delay as i have been away for the last week or is it two
any way maybe

Option Explicit
Sub ptest()
    Dim a, b(), c(), i As Long, ii As Long, n As Long, e, w As Long
    a = Range("A3:C19").Value
    ReDim b(1 To UBound(a, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare
        For i = LBound(a, 1) To UBound(a, 1)
            If Not .Exists(a(i, 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                .Add a(i, 1), n
            End If
            Select Case a(i, 2)
            Case "Fruit"
                b(.Item(a(i, 1)), 2) = a(i, 3)
            Case "Brand"
                b(.Item(a(i, 1)), 4) = a(i, 3)
            Case "Color"
                b(.Item(a(i, 1)), 5) = a(i, 3)
            Case Else
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) & IIf(b(.Item(a(i, 1)), 3) <> "", " , ", "") & a(i, 3)
            w = w + 1
                        
            End Select
        Next
     End With
    ii = 1
    Range("F1").Resize(1, 5).Value = Array("Number", "Fruit", "Value", "Brand", "Color")
    ReDim c(1 To n + w, 1 To 5)
    For i = 1 To n
       c(ii, 1) = b(i, 1): c(ii, 2) = b(i, 2): c(ii, 4) = b(i, 4): c(ii, 5) = b(i, 5)
        For Each e In Split(b(i, 3), ",")
         ii = 1 + ii
           c(ii, 1) = b(i, 1): c(ii, 3) = e
        Next
    ii = 1 + ii
    Next

    Range("F2").Resize(n + w, 5).Value = c
End Sub