Need help to improve my VBA code

[smide]

Hello.

I'm using the following code to parse my raw report from row1-Sheet5 and transfer data to Sheet4, creating this table:

[TABLE="class: grid, width: 250, align: center"]
<tbody>[TR]
[TD="align: center"][/TD]
[TD="align: center"]O[/TD]
[TD="align: center"]P[/TD]
[TD="align: center"]Q[/TD]
[TD="align: center"]R[/TD]
[/TR]
[TR]
[TD="align: center"]1[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]2[/TD]
[TD="align: center"]id
[/TD]
[TD="align: center"]shop
[/TD]
[TD="align: center"]store
[/TD]
[TD="align: center"]factory
[/TD]
[/TR]
[TR]
[TD="align: center"]3[/TD]
[TD="align: center"]3456[/TD]
[TD="align: center"]23[/TD]
[TD="align: center"]15[/TD]
[TD="align: center"]25[/TD]
[/TR]
[TR]
[TD="align: center"]4[/TD]
[TD="align: center"]3467[/TD]
[TD="align: center"]12[/TD]
[TD="align: center"]16[/TD]
[TD="align: center"]28[/TD]
[/TR]
[TR]
[TD="align: center"]5[/TD]
[TD="align: center"]3468[/TD]
[TD="align: center"]24[/TD]
[TD="align: center"]19[/TD]
[TD="align: center"]33[/TD]
[/TR]
[TR]
[TD="align: center"]6[/TD]
[TD="align: center"]....[/TD]
[TD="align: center"]....[/TD]
[TD="align: center"]....[/TD]
[TD="align: center"]....[/TD]
[/TR]
</tbody>[/TABLE]
Data in row1-Sheet5 are organized in the following pattern: id - shop - store - factory

My problem is reflected in the fact that sometimes between the two id's there are no this "shop-store-factory" cells which means that my prices are often in the wrong row in above table (next to the wrong id).

I would like to re-arrange this code so in the case that between the two id's there are no this cells which contains significant text (shop-store-factory), then, in the table, that row stays empty.

example:

(id-shop-store-factory) (id-shop-store-factory) (id) (id-shop-store-factory) (id-shop-store-factory) ....


[TABLE="width: 250, align: center"]
<tbody>[TR]
[TD="align: center"][/TD]
[TD="align: center"]O[/TD]
[TD="align: center"]P[/TD]
[TD="align: center"]Q[/TD]
[TD="align: center"]R[/TD]
[/TR]
[TR]
[TD="align: center"]1[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]2[/TD]
[TD="align: center"]id[/TD]
[TD="align: center"]shop[/TD]
[TD="align: center"]store[/TD]
[TD="align: center"]factory[/TD]
[/TR]
[TR]
[TD="align: center"]3[/TD]
[TD="align: center"]3456[/TD]
[TD="align: center"]23[/TD]
[TD="align: center"]15[/TD]
[TD="align: center"]25[/TD]
[/TR]
[TR]
[TD="align: center"]4[/TD]
[TD="align: center"]3467[/TD]
[TD="align: center"]12[/TD]
[TD="align: center"]16[/TD]
[TD="align: center"]28[/TD]
[/TR]
[TR]
[TD="align: center"]5[/TD]
[TD="align: center"]3468[/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[TD="align: center"][/TD]
[/TR]
[TR]
[TD="align: center"]6[/TD]
[TD="align: center"]3470[/TD]
[TD="align: center"]24[/TD]
[TD="align: center"]19[/TD]
[TD="align: center"]33[/TD]
[/TR]
[TR]
[TD="align: center"]7[/TD]
[TD="align: center"]3471[/TD]
[TD="align: center"]27[/TD]
[TD="align: center"]11[/TD]
[TD="align: center"]39[/TD]
[/TR]
</tbody>[/TABLE]
Here is the code I used so far:

Sub Salary()

[B]' extract id's from row 1 Sheet5
[/B]
Dim C As Long, X As Long, Data As Variant, Result As Variant
  Data = Sheets("Sheet5").Range("A1", Sheets("Sheet5").Cells(1, Columns.Count).End(xlToLeft))
  ReDim Result(1 To UBound(Data, 2), 1 To 1)
  For C = 1 To UBound(Data, 2)
    If Data(1, C) Like "*""[Ii][Dd]"":#*" And _
       Left(LCase(Data(1, C)), 14) <> "annual:[{""id"":" And _
       Left(LCase(Data(1, C)), 15) <> "account:[{""id"":" Then
      X = X + 1
      Result(X, 1) = Mid(Data(1, C), InStrRev(Data(1, C), ":") + 1)
    End If
  Next
  Sheets("Sheet4").Range("O3").Resize(UBound(Result)) = Result


[B]'extract shop-store-factory prices from row 1 Sheet5
[/B]
Dim a As Variant, b As Variant
  Dim i As Long, k As Long, pos As Long
  
  With Sheets("Sheet5")
    a = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Value
  End With
  ReDim b(1 To UBound(a, 2), 1 To 3)
  For i = 1 To UBound(a, 2) - 2
    pos = InStr(1, a(1, i), "{""shop"":", vbTextCompare)
    If pos > 0 And IsNumeric(Mid(a(1, i), pos + 8)) Then
      k = k + 1
      b(k, 1) = Val(Mid(a(1, i), pos + 8))
      b(k, 2) = Val(Mid(a(1, i + 1), InStr(1, a(1, i + 1), ":") + 1))
      b(k, 3) = Val(Mid(a(1, i + 2), InStr(1, a(1, i + 2), ":") + 1))
    End If
  Next i
  If k > 0 Then
    Sheets("Sheet4").Range("P3:R3").Resize(k).Value = b
  End If

End Sub

 

[oldbrewer]

your new table is the same as the original table ie first 2 rows are identical

 

[smide]

your new table is the same as the original table ie first 2 rows are identical

Yes, but the whole point is in row five (or row three if you exclude first two) which is empty because there is no this shop-store-factory cells between two id's (between 3rd and 4th id).
Of course the 3rd id is equal to 3468 ie the contents of that cell is: {"id":3468

 

[oldbrewer]

id1
id2
id3
id4
id5
id1
id3
id5

<colgroup><col span="2"></colgroup><tbody>
[TD="colspan: 2"]if your data was this[/TD]

[TD="align: right"]88[/TD]

[TD="align: right"]66[/TD]

[TD="align: right"]44[/TD]

[TD="colspan: 2"]is your desired output[/TD]

[TD="align: right"]88[/TD]

[TD="align: right"]66[/TD]

[TD="align: right"]44[/TD]

</tbody>