PDA

View Full Version : [SOLVED] VBA to paste to new sheets if column is blank



roxnoxsox
09-03-2015, 02:10 AM
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
09-03-2015, 04:43 AM
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.
09-03-2015, 06:16 AM
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
09-03-2015, 06:35 AM
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
09-04-2015, 04:32 AM
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
09-04-2015, 07:57 AM
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
09-05-2015, 04:06 AM
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
09-24-2015, 08:12 AM
Hi vcoolio, no sorry I don't seem to have received any notification about this! But the code seems to work perfectly, thank you :D Much appreciated!

vcoolio
09-25-2015, 01:01 AM
Hello Roxnoxsox,

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

Cheerio,
vcoolio