Generate List if Conditions Are Met

[Legacy 323112]

Hi all,
I am trying to do the following with VBA and have had some trouble, would appreciate any ideas;

- I have an array of data in my excel spreadsheet (range("A2:D401").
- In column D2, I am performing a calculation of B2 minus C2. This formula extends for each row until row 401.
- Once calculated, I want to generate a new sheet with a list of only the values in columns A, E and F for only the records that have values in column D that are less than or equal to 150. This is to be looped and so I would like this list, if generated, to be appended to each time.

Please help!
Thanks

Example;

In this example, I would like an output in another spreadsheet of "JOHN" "TYPE-2" "AGE-20", because NUMBER3 for JOHN is <150
However, there should be no output of MARY.


[TABLE="width: 651"]
<tbody>[TR]
[TD="class: xl65, width: 93"][/TD]
[TD="class: xl65, width: 93"]A[/TD]
[TD="class: xl65, width: 93"]B[/TD]
[TD="class: xl65, width: 93"]C[/TD]
[TD="class: xl65, width: 93"]D[/TD]
[TD="class: xl65, width: 93"]E[/TD]
[TD="class: xl65, width: 93"]F[/TD]
[/TR]
[TR]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]NAME[/TD]
[TD="class: xl65"]NUMBER 1[/TD]
[TD="class: xl65"]NUMBER 2[/TD]
[TD="class: xl65"]NUMBER 3[/TD]
[TD="class: xl65"]TYPE[/TD]
[TD="class: xl65"]AGE[/TD]
[/TR]
[TR]
[TD="class: xl65"]2[/TD]
[TD="class: xl65"]JOHN[/TD]
[TD="class: xl65"]200[/TD]
[TD="class: xl65"]12[/TD]
[TD="class: xl65"]88[/TD]
[TD="class: xl65"]1[/TD]
[TD="class: xl65"]20[/TD]
[/TR]
[TR]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]MARY[/TD]
[TD="class: xl65"]200[/TD]
[TD="class: xl65"]10[/TD]
[TD="class: xl65"]190[/TD]
[TD="class: xl65"]3[/TD]
[TD="class: xl65"]22[/TD]
[/TR]
</tbody>[/TABLE]

 

[Legacy 323112]

Any help would be most appreciated!
Thanks!

 

[Legacy 323112]

This is what I have so far;

            Set cell = Range("D2:D401")
            Do Until cell.value = ""
                value = Val(cell.value)
                If (value <= 150) Then
                    'Copy values from column A, E and F
                    'Append these values to new sheet
                End If
                Set cell = cell.Offset(1)
            Loop

But I am having trouble in referencing the value in column A as this will vary depending on the row

 

[L. Howard]

Hi Ash_23S,

Try this in a standard module.

Edit your sheet names for my sheets 3 & 4.

(I believe your math is incorrect for John in your posted data)

Howard

Option Explicit

Sub OneRangeTest()

Dim OneRng As Range
Dim c As Range

Set OneRng = Sheets("Sheet3").Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)

For Each c In OneRng
  If c < 150 Then
    Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)(2) = _
    c.Offset(, -3) & " Type-" & c.Offset(, 1) & " Age-" & c.Offset(, 2)
    End If
Next
End Sub

 

[Legacy 323112]

Thanks very much! This is great!

Is there a quick modification that separates the three values and puts them into adjacent cells, rather than one long string in one cell? If not, not to worry!

 

[Legacy 323112]

With your help, I have got to the next stage as follows;

            'Calculate
            Range("D2:D401").Formula = "=B2-C2"
            'Output as values
            Set OneRng = Sheets("Sheet1").Range("D2:D" & Cells(rows.Count, "D").End(xlUp).Row)
            For Each c In OneRng
              If c < 150 Then
                Sheets("Sheet2").Range("A" & rows.Count).End(xlUp)(2) = _
                c.Offset(, -3) & ": Cycle - " & c.Offset(, 1) & ": Concentration - " & c.Offset(, 2)
                End If
            Next
            'Append List
            Sheets("To Re-Fill").Activate
            If Range("A2") <> "" Then
                Range("A:A").Copy
                ThisWorkbook.Sheets("Output").Activate
                'Paste as values into next empty row
                
            End If

I am experiencing a problem when trying to paste as values to the next empty row in the output sheet of this workbook. (the other sheets are of different workbooks). If I try to paste as usual, without trying to target the next empty row, it works perfectly.. But when trying to target the next empty row, I result in nothing pasted at all..

 

[L. Howard]

Thanks very much! This is great!

Is there a quick modification that separates the three values and puts them into adjacent cells, rather than one long string in one cell? If not, not to worry!

Here is a not so eloquent way.

About 2 seconds with 1000 rows.

I believe there is a Join-Split method that will be much faster. I'll look into it.

Howard

Option Explicit

Sub FourLineRange()
Dim OneRng As Range
Dim c As Range

Set OneRng = Sheets("Sheet3").Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)

For Each c In OneRng
  If c < 150 Then
    Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)(2) = c.Offset(, -3)
    Sheets("Sheet4").Range("B" & Rows.Count).End(xlUp)(2) = " Type-" & c.Offset(, 1)
    Sheets("Sheet4").Range("C" & Rows.Count).End(xlUp)(2) = " Age-" & c.Offset(, 2)
    End If
Next
End Sub

 

[Legacy 323112]

Thanks! That's good enough for me!

With your help, I have got to the next stage where I want to append this data to another list as follows;

            'Append List
            Sheets("To Re-Fill").Activate
            If Range("A2") <> "" Then
                Range("A:A").Copy
                ThisWorkbook.Sheets("Output").Activate
                'Paste as values into next empty row
                
            End If

I am experiencing a problem when trying to paste as values to the next empty row in the output sheet of this workbook. (the other sheets are of different workbooks). If I try to paste as usual, without trying to target the next empty row, it works perfectly.. But when trying to target the next empty row, I result in nothing pasted at all..

 

[L. Howard]

Thanks! That's good enough for me!

With your help, I have got to the next stage where I want to append this data to another list as follows;

            'Append List
            Sheets("To Re-Fill").Activate
            If Range("A2") <> "" Then
                Range("A:A").Copy
                ThisWorkbook.Sheets("Output").Activate
                'Paste as values into next empty row
                
            End If

I am experiencing a problem when trying to paste as values to the next empty row in the output sheet of this workbook. (the other sheets are of different workbooks). If I try to paste as usual, without trying to target the next empty row, it works perfectly.. But when trying to target the next empty row, I result in nothing pasted at all..

A re-write of the code in post #7. Not sure it's faster however. Posts to column A, C, E on sheet 4.

Option Explicit

Sub Column_OneRng1()
Dim LRow As Long, i As Long
Dim varData As Variant

Application.ScreenUpdating = False
With Sheets("Sheet3")
    LRow = .Cells(Rows.Count, 4).End(xlUp).Row
    varData = .Range("A2:F" & LRow)
    For i = 1 To UBound(varData)
        If varData(i, 4) < 150 Then
            Sheets("Sheet4").Cells(Rows.Count, 1) _
                .End(xlUp)(2) = varData(i, 1)
                
            Sheets("Sheet4").Cells(Rows.Count, 3) _
                .End(xlUp)(2) = " Type-" & varData(i, 5)
                
            Sheets("Sheet4").Cells(Rows.Count, 5) _
                .End(xlUp)(2) = " Age-" & varData(i, 6)
                
        End If
    Next
End With

Application.ScreenUpdating = True

End Sub

See if you can make this work for you, for the next row.
Where the (2) will be the next empty row, a (3) will produce a blank row between copies and a (1) will over write the last copy.

Range("A" & Rows.count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues

Howard

 

[Legacy 323112]

Thank you!

All works, except the paste!

Code:

Sheets("To Re-Fill").Activate
            If Range("A2") <> "" Then
                Range("A:A").Copy
                ThisWorkbook.Sheets("Output").Activate
                'Paste as values into next empty row - not working
                Range("A" & rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            End If