How to copy and paste specific row header values from sheet 1 to Sheet 2 through VBA

[eun]

I have a specific row header as below where i need to copy the range of value at E:E referencing to the header and paste to sheet 2 as below until it was blank and no more data. is a dynamic worksheet where the number of items may increase or decrease on daily extracts, but i do not know how to declare the information below so to instruct to copy the ID88888 by referencing only the Items (header name), and using which looping function. I really need some help here to get started.

Key point is there are gaps from the below info

at sheet1:
D7:E7
Item : ID88888
date purchase:18.1.16
expiry date: 20.1.16
cost: 10

D20:E20
Item : ID99999
date purchase:18.1.16
expiry date: 20.1.16
cost: 15

at sheet 2:
expected VBA results:

Apple|date purchase|expiry date|cost|
ID88888|18.1.16|20.1.16|10|
ID99999|18.1.16|20.1.16|15|

----------------------------------------------------------------------------
Mod Edit: Question moved to VBA section

 

[Nebu]

Hi:
Please upload a sample file, it will be easier for someone who is giving solutions to work with a sample file.

Thanks

 

[eun]

Hi Nebu,

Pls see the attached s/s with requirement stated with the modules.

Thanks,
Eun

 

[John Jairo V]

Hi @eun (and @Nebu)

Check this code:

Sub Extract()
  Dim uf&, uf2&, i&, v
  Dim ws1 As Worksheet, ws2 As Worksheet
 
  Set ws1 = Sheets("Source")
  Set ws2 = Sheets("Results")
 
  With Application
      .ScreenUpdating = False
      uf = ws1.Range("C" & Rows.Count).End(xlUp).Row
      v = Evaluate("IF(D1:D" & uf & "=""Internal Id:"",ROW(D1:D" & uf & "))")
      v = Filter(.Transpose(v), False, False)
     
      ' Clear old data from sheets results
      ws2.Range("A1").CurrentRegion.Offset(1).Clear
     
      For i = 0 To UBound(v)
        uf2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        ws1.Range("E" & v(i)).Resize(10).Copy
        ws2.Range("A" & uf2).PasteSpecial xlPasteValues, Transpose:=True
      Next i
     
      .Goto ws2.Range("A1")
      Set ws1 = Nothing: Set ws2 = Nothing: Erase v
      .ScreenUpdating = True
  End With
End Sub

Blessings!

 

[eun]

Hi John,
Thanks so much for your help, as I am still very new to VBA and not an advance user yet, I am not able to comprehend the answer you have provided is not so straight forward for me, could you kindly explain in details.

Qn1) what does the below Dim implies or reference to
Dim uf&, uf2&, i&, v

Qn2) Are you also able to explain how to derive each logic below and how to reference to the location of the data which I have attached earlier.
I needed to understand it to apply the below example to my current issue. Your help is greatly appreciated.
With Application
.ScreenUpdating = False
uf = ws1.Range("C" & Rows.Count).End(xlUp).Row
v = Evaluate("IF(D1:D" & uf & "=""Internal Id:"",ROW(D1:D" & uf & "))")
v = Filter(.Transpose(v), False, False)

' Clear old data from sheets results ws2.Range("A1").CurrentRegion.Offset(1).Clear

For i = 0 To UBound(v)
uf2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("E" & v(i)).Resize(10).Copy
ws2.Range("A" & uf2).PasteSpecial xlPasteValues, Transpose:=True
Next i

.Goto ws2.Range("A1")
Set ws1 = Nothing: Set ws2 = Nothing: Erase v
.ScreenUpdating = True
End With
End Sub

 

[eun]

Hi all,

I was trying to apply the above example to my reports, having debugging issue on this{ v = Filter(.Transpose(v), False, False)}, having run-time error'13' type mismatch, what could be main reason for it
since the data are similar

 

[eun]

Hi John,

I have queries and question for you with regards to the code you have written, as i am new and still learning, i really do wish you could comment more throughout the coding as to better my understand on the code which you have written, as i am trying to adapt your code to my existing data, does not seem to work as the reports are having more rows than the data that i send to you, it seems that the arrays are not dynamic enough to cater for the 300000 rows or more, this was what i got the advise from my colleague, as they have their stuff to do , no one has the time to go through the code to help me understand further and how should i approach the issue. Would it be possible if you can write a code that does not use arrays instead of other looping methods?

 

[John Jairo V]

Try this new code. It takes around 18 secs (in my computer) to work with 300000 rows.

Sub Extract()
  Dim uf&, uf2&, i&, v, t!
  Dim ws1 As Worksheet, ws2 As Worksheet
 
  t = Timer
  Set ws1 = Sheets("Source")
  Set ws2 = Sheets("Results")
 
  With Application
      .ScreenUpdating = False
      uf = ws1.Range("C" & Rows.Count).End(xlUp).Row
     
      With Range("AA1:AA" & uf)
        .Value2 = Evaluate("IF(D1:D" & uf & "=""Internal Id:"",ROW(D1:D" & uf & "))")
        .RemoveDuplicates 1, xlNo
        v = Range("AA2", Range("AA1").End(xlDown)).Value2
      End With
     
      Range("AA1").CurrentRegion.ClearContents
      ' Clear old data from sheets results
      ws2.Range("A1").CurrentRegion.Offset(1).Clear
     
      For i = 1 To UBound(v)
        uf2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        ws1.Range("E" & v(i, 1)).Resize(10).Copy
        ws2.Range("A" & uf2).PasteSpecial xlPasteValues, Transpose:=True
      Next i
     
      .Goto ws2.Range("A1")
      Set ws1 = Nothing: Set ws2 = Nothing: Erase v
      .CutCopyMode = False: .ScreenUpdating = True
      MsgBox "Time to process: " & Format(Timer - t, "0.000 seg"), , "Done !!!"
  End With
End Sub

Blessings!

 

[jindon]

Try this...

Sub test()
    Dim x, i As Long, flg As Boolean, n As Long
    Application.ScreenUpdating = False
    Sheets("results").Cells(1).CurrentRegion.Clear: n = 1
    With Sheets("source")
        x = Filter(.[transpose(if((d1:d500000="Internal Id:")+(d1:d500000="Cost Price"),row(1:500000),char(2)))], Chr(2), 0)
        For i = 0 To UBound(x) Step 2
            With .Range(.Cells(x(i), "d"), .Cells(x(i + 1), "d")).Offset(, IIf(flg, 1, 0)).Resize(, IIf(flg, 1, 2))
                Sheets("results").Cells(n, 1).Resize(.Columns.Count, .Rows.Count).Value = _
                Application.Transpose(.Value)
                n = n + IIf(flg, 1, 2): flg = True
            End With
        Next
    End With
    Application.ScreenUpdating = True
End Sub