VBA to copy a set of values in a row based on a criteria in the parallel row into another worksheet and at different intervals

[benajamingeldart]

Hi folks,
Usually, this forum sorts me out without a special request but i am struggling with the database from hell based on chemical elements.

I would like to copy the chemical elements listed across a single row in a worksheet called "Conversion" based on if the row beneath has a criteria "ppm". This data will be somewhere across rows 1 and 4 but i don't want to put in cell or row ranges to keep it flexible in its search. The list generated could be of any size as well.
Then i want to transpose and paste it into a workbook called ("Test") in a column called "Element" and repeatedly pasted throughout the column immediately below the previous pasting in a loop.

Alternately i have managed to pre-format the "Test" workbook by inserting blank rows based on countif of "ppm" from the "conversion" workbook cell A1 to make a repeated gap for the elements down a list ID's. Below is the code. If it is possible to combine the countif (ppm in sheet"conversion")-insert blank rows (sheet "Test")-transpose/paste data (sheet "Test"- heading "Element") and repeat that would be ideal but i don't mind pulling together a host of sub routines if required.

Sub InsertBlankRows()
Application.ScreenUpdating = False
Dim numRows As Long
Dim r As Long
Dim Rng As Range
Dim lastrw As Long
numRows = Range("A1").Value
'Note: cells(r,1) is same as cells(r,"A")
lastrw = Cells(Rows.count, "A").End(xlUp).Row
Set Rng = Range(ActiveCell, Cells(lastrw, "A"))
For r = Rng.Rows.count To 1 Step -1
' (r+1) to insert AFTER, (r) to insert BEFOE
Rng.Rows(r + 1).Resize(numRows).EntireRow.Insert
Next r
Application.ScreenUpdating = True
End Sub

Thanks.

 

[JLGWhiz]

Would something like this work for you?

Sub t()
Dim fn As Range, Sh1 As Worksheet, sh2 As Worksheet, adr
Set Sh1 = Sheets("Conversion")
Set sh2 = Sheets.Add(After:=Sh1)
Set fn = Sh1.UsedRange.Offset(1).Find("ppm", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        adr = fn.Address
        Do
            fn.Offset(-1).Resize(2).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            Set fn = Sh1.UsedRange.Offset(1).FindNext(fn)
        Loop While fn.Address <> adr
    End If
End Sub

 

[benajamingeldart]

Thanks for your response. It kind of worked. It pulled the elements across into a new worksheet and transposed the data from the search but also transferred the ppm search criteria under each element which isn't required. I also need it to be copied and pasted through a loop on the test sheet in column E where I have now put an X but based on if there is data in column A. I've attached a couple of snapshots

to explain a little clearer including what the elements list needs to look like on the "Test" sheet. The original list with ppm is included on the "conversion" sheets.

 

[JLGWhiz]

This will give you something to work with, but there are too many unexplained variables to offer any reliable code.

Sub t2()
Dim fn As Range, Sh1 As Worksheet, sh2 As Worksheet, adr, tst As Long, rws As Long, ary() As Variant, i As Long
Set Sh1 = Sheets("Conversion")
Set sh2 = Sheets("Test")
tst = Application.CountA(Sheets("Test").Range("A5:A" & Rows.Count)) 'get number of stations
rws = Application.CountIf(Sheets("Conversion").Rows("1:4"), "ppm")
Set fn = Sh1.UsedRange.Offset(1).Find("ppm", , xlValues, xlWhole)
    If Not fn Is Nothing Then
        adr = fn.Address
        Do
          x = x + 1
            ReDim Preserve ary(1 To x)
            ary(x) = fn.Offset(-1).Value
            Set fn = Sh1.UsedRange.Offset(1).FindNext(fn)
        Loop While fn.Address <> adr
    End If
    For i = 5 To (tst * rws) Step rws
        Sheets("Test").Cells(i, 5).Resize(rws) = Application.Transpose(ary)
    Next
End Sub

How do you determine the number of stations that will be used? How do you know the number of rows that currently exist between stations on Conversion sheet? and a couple of others.