Transpose or Vlookup

Option Explicit
Option Compare Text

Sub ReFormatData()
'JBeaucaire  (11/5/2009)
Dim LR As Long, LC As Long, NR As Long, i As Long, r As Long
Dim MyArr, MyStr As String

LC = Cells(1, Columns.Count).End(xlToLeft).Column
LR = Range("A1").SpecialCells(xlCellTypeLastCell).Row
NR = LR + 2

Range("A" & LR + 1, "C" & LR + 1).Interior.ColorIndex = 24
Range("A" & LR + 2) = "IDFORM"
Range("B" & LR + 2) = "ITEM"
Range("C" & LR + 2) = "QTY"

For i = 1 To LC
    MyStr = Replace(Cells(1, i), "idform:*", "")
    For r = 2 To LR
    Select Case Left(Cells(r, i), 4)
        Case "ITEM"
            NR = NR + 1
            Range("A" & NR) = MyStr
            r = r + 1
            If Not Left(Cells(r, i), 3) = "Sub" And Not Left(Cells(r, i), 3) = "Gra" Then
                Range("B" & NR) = Cells(r, i)
                If IsNumeric(Left(Cells(r + 1, i), 1)) Then
                    MyArr = Split(Cells(r + 1, i), " ")
                    Range("C" & NR) = MyArr(1)
                Else
                    Range("B" & NR, "C" & NR) = 0
                End If
            End If
            r = r + 1
        Case "Sub ", "Gran", ""
            Exit For
        Case Else
            NR = NR + 1
            Range("A" & NR) = MyStr
            If Not Left(Cells(r, i), 3) = "Sub" And Not Left(Cells(r, i), 3) = "Gra" Then
                Range("B" & NR) = Cells(r, i)
                If IsNumeric(Left(Cells(r + 1, i), 1)) Then
                    MyArr = Split(Cells(r + 1, i), " ")
                    Range("C" & NR) = MyArr(1)
                End If
            Else
                Range("B" & NR, "C" & NR) = 0
            End If
            r = r + 1
        End Select
    Next r
Next i
End Sub

Option Explicit
Sub MoveData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range, firstaddress As String, Sp
Dim LR As Long, LC As Long, NC As Long, NR As Long, a As Long, b As Long, rng As Range
Dim Myidform As String
Application.ScreenUpdating = False
Set ws1 = Worksheets("DATA")
Set ws2 = Worksheets("TABEL")
With ws2
  .Cells.ClearContents
  .Range("A1").Resize(, 3).Value = [{"idform","Item","QTY"}]
End With
ws1.Select
With ws1
  LC = .Cells(1, Columns.Count).End(xlToLeft).Column
  For NC = 1 To LC Step 1
    NR = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    Myidform = Right(.Cells(1, NC), Len(.Cells(1, NC)) - WorksheetFunction.Find("*", .Cells(1, NC), 1))
    Set rng = .Columns(NC)
    a = Application.WorksheetFunction.CountIf(rng, "GSM*")
    ws2.Range("A" & NR & ":A" & NR + a - 1) = Myidform
    If a = 0 Then
      ws2.Range("B" & NR) = 0
      ws2.Range("C" & NR) = 0
    Else
      With .Columns(NC)
        Set c = .Find("GSM*", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            ws2.Range("B" & NR) = c
            Sp = Split(c.Offset(1), " ")
            ws2.Range("C" & NR) = Sp(1)
            NR = NR + 1
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  Next NC
End With
ws2.Select
Application.ScreenUpdating = True
End Sub

Option Explicit
Sub MoveData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range, firstaddress As String, Sp
Dim LR As Long, LC As Long, NC As Long, NR As Long, a As Long, b As Long, rng As Range
Dim Myidform As String
Application.ScreenUpdating = False
Set ws1 = Worksheets("DATA")
Set ws2 = Worksheets("TABEL")
With ws2
  .Cells.ClearContents
  .Range("A1").Resize(, 3).Value = [{"idform","Item","QTY"}]
End With
ws1.Select
With ws1
  LC = .Cells(1, Columns.Count).End(xlToLeft).Column
  For NC = 1 To LC Step 1
    NR = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    Myidform = Right(.Cells(1, NC), Len(.Cells(1, NC)) - WorksheetFunction.Find("*", .Cells(1, NC), 1))
    Set rng = .Columns(NC)
    a = Application.WorksheetFunction.CountIf(rng, "GSM*")
    If a = 0 Then
      ws2.Range("A" & NR) = Myidform
      ws2.Range("B" & NR) = 0
      ws2.Range("C" & NR) = 0
    Else
      ws2.Range("A" & NR & ":A" & NR + a - 1) = Myidform
      With .Columns(NC)
        Set c = .Find("GSM*", LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
          firstaddress = c.Address
          Do
            ws2.Range("B" & NR) = c
            Sp = Split(c.Offset(1), " ")
            ws2.Range("C" & NR) = Sp(1)
            NR = NR + 1
            Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
      End With
    End If
  Next NC
End With
ws2.Select
Application.ScreenUpdating = True
End Sub