Thread: VBA: Copy cell if specific column meets 2 conditions

Hi,

Would very much appreciate your help with this VBA excel query.
I am using Excel 2007.

Looking for VBA code that will progress through many rows to check if 2 conditions are met:

1) Specific column is NOT blank
AND
2) Specific column contains an integer i such that 0 < i < 1

if so, copy certain cells from that row to a second worksheet, repeating until row containing "THE END"

I have broken down the 'logic' as follows.

1) Popup a Textbox, Input text = ColumnLetter ("Enter Column Letter. e.g. AA")
2) Popup a Textbox, Input text = EndRow ("Enter End Row Number. e.g. 2000")
3) Set ColumnLetter as a string
4) Set EndRow as a string
5) Define the InputSheet as "InputSheetName"
6) Define the OutputSheet as "OutputSheetName"
7) If Column J is NOT blank AND "ColumnLetter" is integer 0 < i < 1.0

Then copy Column J on InputSheet to Column B on OutputSheet
Then copy Column C on InputSheet to Column C on OutputSheet
Then copy Column F on InputSheet to Column D on OutputSheet
Then copy Column E on InputSheet to Column E on OutputSheet
Then copy "ColumnLetter" on InputSheet to Column F on OutputSheet

Repeat from Row 4 to "EndRow"

I have also attached a much simpler sample worksheet.
Appreciate that autofilter would work for a simple example, however the actual data sheet has ~ 50 columns and 5000 rows

Many thanks for any advice or assistance.

Hi dangelor,

That's really awesome, thanks very much.
Had to make a few minor changes to correct my own oversight in the 'logic'
This is my current version

Sub Copy_on_2_Conditions()

	Dim sColLetter As String, sEndRow As Integer
 	Dim wksI As Worksheet, wksO As Worksheet
    Dim FirstCellOfMerge As Range
    Dim x           As Long

    ' Define the InputSheet as "InputSheetName"
    Set wksI = Worksheets("InputSheet")
    ' Define the OutputSheet as "OutputSheetName"
    Set wksO = Worksheets("OutputSheet")
    
    Application.ScreenUpdating = False
    ' Popup a Textbox, Input text = ColumnLetter ("Enter Column Letter. e.g. AA")
    sColLetter = InputBox("Enter Column Letter. e.g. AA")
    If Len(sColLetter) = 0 Then Exit Sub

    ' Popup a Textbox, Input text = EndRow ("Enter End Row Number. e.g. 2000")
    sEndRow = InputBox("Enter End Row Number. e.g. 2000")

    With wksI
        'Repeat from Row 4 to "EndRow"
        For x = 4 To sEndRow
            ' If Column J is NOT blank AND "ColumnLetter" is integer 0 < i < 1.0 AND Ignore subtotal "Total Seats" row
            If Not IsEmpty(.Range("J" & x)) And _
               .Range("J" & x) <> "Total Seats" And _
               .Range(sColLetter & x) > 0 And _
               .Range(sColLetter & x) <= 1 Then

                'Then copy Column J on InputSheet to Column B on OutputSheet
                wksO.Range("B" & x) = .Range("J" & x)

                'Then copy Column C on InputSheet to Column C on OutputSheet
				'Takes first value where Merged Cells are used
                Set FirstCellOfMerge = Range("C" & x).MergeArea.Cells(1, 1)
                wksO.Range("C" & x) = FirstCellOfMerge

                'Then copy Column F on InputSheet to Column D on OutputSheet
                wksO.Range("D" & x) = .Range("F" & x)

                'Then copy Column E on InputSheet to Column E on OutputSheet
                wksO.Range("E" & x) = .Range("E" & x)

                'Then copy "ColumnLetter" on InputSheet to Column F on OutputSheet
                wksO.Range("F" & x) = .Range(sColLetter & x)
            End If
        Next x
    End With
    wksO.Columns("A:F").EntireColumn.AutoFit
End Sub

Currently the 'Copy column to OutputSheet' keeps the x row number the same, this means that Sheet 2 can have lots of blanks
I'm trying to sort out an autofilter on OutputSheet, range B2 to the last populated cell in column F
Is there a neat way to define that range?

The way I prefer is to sort the Out list, sending the blank rows to the bottom or use .Specialcells (xlCellTypeBlanks) and delete entire rows.

HTH
-Rich

Originally Posted by Aakron

Is there a neat way to define that range?

Try...

Range ("a4:f" & Range("f" & Rows.Count).End(xlUp).Row)