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

New Member
Joined
Dec 10, 2006
Messages
15
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.
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
Would something like this work for you?

VBA Code:
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

New Member
Joined
Dec 10, 2006
Messages
15
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
ppm search list.JPG
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.
 

Attachments

  • elements list.JPG
    elements list.JPG
    118.5 KB · Views: 2

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
This will give you something to work with, but there are too many unexplained variables to offer any reliable code.

VBA 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.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,194
Messages
5,546,489
Members
410,742
Latest member
WalterSil
Top