VBA to paste to new sheets if column is blank

[roxnoxsox]

Hi there, I wondered if anyone could help me with this problem?

I have a list of data in columns C, D, E & F like as below:

Apple 4.5 USD 12/07/2015
Banana 5.1 CAD 01/08/2015
Orange GBP 13/02/2015
Grape 10020 USD
Cherry 1.009 CNY 10/10/2014

Sometimes, column D or F are empty (ie. they don't contain a price or a date). I need a macro which would look for those with nothing in column D and/or nothing in column F - cut this entire row and paste it into a new sheet. The range of data I'm working with would change each day.

Also (if possible) where rows have been cut and pasted to the new sheet, I'd like the data to automatically shift up rather than just leaving a blank row on the original spreadsheet? Is this possible? Please let me know if you need any further information at all!!

[vcoolio]

Hello Roxnoxsox,

Does the following code help?

Sub CopyStuff()


Application.ScreenUpdating = False


      Dim lRow As Long
      lRow = Range("A" & Rows.Count).End(xlUp).Row


For Each cell In Range("D2:D" & lRow, "F2:F" & lRow)
      If cell.Value = "" Then
      cell.EntireRow.Cut Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next


Columns("D").SpecialCells(4).EntireRow.Delete
Application.ScreenUpdating = True
Sheet2.Select


End Sub

I've attached my test work book for you to peruse.

I hope that this helps.

Cheerio,
vcoolio.

[Keven.]

Sub Move_Record()

Dim rng As Range
Dim wksht As Worksheet
Set rng = Sheets("Data").Range("C1").CurrentRegion
Set wksht = Worksheets.Add

Sheets("Data").Activate

rng.SpecialCells(xlCellTypeBlanks).EntireRow.Copy
wksht.Paste
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Sheets("Data").Range("C1").Select

End Sub

[roxnoxsox]

Hi all, many many thanks for fast replies. Would this still work if columns A and B were empty?

I can see that these are working on the test spreadsheets you attached but don't seem to work when I try on my spreadsheet (see example as attached).

[vcoolio]

Hello Roxnoxsox,

See if this works:-

In your sample, try entering something in columns A & B and then saving the file as an xlsm type.


Cheerio,
vcoolio.

[roxnoxsox]

Hi vcoolio, many thanks for your above reply. Is it possible to adjust the macro to work based on a column other than A&B? For example, column C will NEVER be blank so if it needs to count the number of rows, could it base on this?

[vcoolio]

Hello Roxnoxsox,

Tell me. Have you been receiving notification of replies to your thread? Just wondering because I haven't been receiving them from this forum even though my settings are correctly set. So, I've just been checking in intermittently to see if anyone whom I've been trying to help still needs help.

Anyway, back to your request:-

Try the following instead (I've amended the code using your work book sample):-

Sub CopyStuff()
     
Application.ScreenUpdating = False
     
    Dim lRow As Long
    lRow = Range("C" & Rows.Count).End(xlUp).Row
     
    For Each cell In Range("D2:D" & lRow, "F2:F" & lRow)
        If cell.Value = "" Then
        Range(Cells(cell.Row, "C"), Cells(cell.Row, "J")).Cut Sheet2.Range("C" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next
     
    Columns("D").SpecialCells(4).EntireRow.Delete
    Sheet2.Range("C1:J" & Rows.Count).RemoveDuplicates Columns:=1, Header:=xlYes
    Sheet2.Columns.AutoFit
    Application.ScreenUpdating = True
    Sheet2.Select
    
End Sub

I think it should do the task for you.

Cheerio,
vcoolio.

[roxnoxsox]

Hi vcoolio, no sorry I don't seem to have received any notification about this! But the code seems to work perfectly, thank you Much appreciated!

[vcoolio]

Hello Roxnoxsox,

You're welcome. Glad that I could help.
(I'm assuming that you will eventually receive notification of this reply!).

Cheerio,
vcoolio