VBA to search column and copy entire rows to new sheet

[Padthelad]

Hello,

I have a problem where I want to be able to search a particular column and then copy that entire row to a new workbook based on the value found in the particular column.

I have the following worksheet called '2016':-

	A	B	C	D	E	F	G	H	I	J	K	L	M
1	DATE	NAME	DATE PAID	INV NO	NET	VAT	TOTAL	Daily net	Gross Total Outstanding		Net LC	Net TB	Monthly Totals
2	06/10/2016	Customer 1	06/10/2016	38216	130.68	26.14	156.82
3	06/10/2016	TB - TB101 Customer 2	deposit paid	38217	11,990.00	2,398.00	14,388.00		7194.00	Balance Remain		11990.00
4	06/10/2016	TB - TB102 Customer 3	deposit paid	38218	1,170.00	234.00	1,404.00		702.00	Balance Remain		1170.00
5	06/10/2016	MM - MM101 Customer 4	deposit paid	38219	4,383.33	876.67	5,260.00		2630.00	Balance Remain	4383.33
6	06/10/2016	Customer 5		38220	117.00	23.40	140.40
7	06/10/2016	TB - TB103 Customer 6	deposit paid	38221	258.33	51.67	310.00	18,049.34	155.00	Balance Remain		258.33
8	07/10/2016	Customer 7		38222	3.92	0.78	4.70
9	07/10/2016	Customer 8		38223	127.37	25.47	152.84
10	07/10/2016	Customer 9	07/10/2016	38224	231.05	46.21	277.26
11	07/10/2016	Customer 10		38225	928.05	185.61	1,113.66
12	07/10/2016	Customer 11		38226	238.83	47.77	286.60
13	07/10/2016	Customer 12		38227	92.73	18.55	111.28

<tbody>
</tbody>

I would like VBA code to be able to search column C for "deposit paid", if this parameter is met, I would like to copy the entire row to a new workbook, including formatting.

I am currently using the following code, however it only copies the workbook headers and first row but without using the 'Column C' parameters I require.

Sub GenerateList()
Dim Cell As Range, cRange As Range
Dim LastRow As Long, LastRow2 As Long
Dim wb As Workbook, wb2 As Workbook



Set wb = ActiveWorkbook


LastRow = wb.Sheets("2016").Cells(Rows.Count, "A").End(xlUp).Row
Set cRange = wb.Sheets("2016").Range("M2:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("2016").Range("A1:M2").Copy wb2.Sheets(1).Range("A2")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    For Each Cell In cRange
       
        If Cell.Value = "deposit paid" Then
            Cell.EntireRow.Copy
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlPasteFormats
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlValues
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If


wb2.Sheets(1).Range("A2:A" & LastRow2).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


End Sub

Any help anyone can provide is very much appreciated.

Many thanks,

Pad

 

[baitmaster]

I can't see anything glaringly obvious, so I suggest you do some debugging.

Make sure you can see the immediate window and the locals window, plus try to have both the VB Editor and the Excel window visible at the same time - use 2 screens if you can

Add a break point at the line [For Each Cell In cRange]. Your code will run to this point. Then step through the code a line at a time by hitting F8. You should see the relevant changes happening to your Excel files. You should also see the way that your code is moving through your loops (if at all) and the values of the different variables as you step through. You can write individual lines of code in the immediate window at any time to change variables or ask questions, and you can pass text / values to this window using the line [debug.print "my text here" & myVariable]

 

[dachickenMind]

Try this:

Sub GenerateList()
Dim Cell As Range, cRange As Range
Dim LastRow As Long, LastRow2 As Long
Dim wb As Workbook, wb2 As Workbook






Set wb = ActiveWorkbook




LastRow = wb.Sheets("2016").Cells(Rows.Count, "A").End(xlUp).Row
Set cRange = wb.Sheets("2016").Range("C2:C" & LastRow) ' changed




If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("2016").Range("A1:M1").Copy wb2.Sheets(1).Range("A1")  'changed
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    For Each Cell In cRange
       
        If Cell.Value = "deposit paid" Then
            Cell.EntireRow.Copy
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlPasteFormats
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlValues
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If




wb2.Sheets(1).Range("A2:A" & LastRow2).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal




End Sub

You can say "THANK YOU" for help received by clicking "Like" in the bottom right corner of the helper's post.

 

[baitmaster]

ah yes, you're using column M to determine the end of the table. I hardly ever use this common approach, for me the following is a more robust solution, it considers the actual last used row of the whole worksheet - not just one column, it ignores "dead space" within the usedrange object, and returns 0 for empty sheets; it is also easy to use anywhere:

Function lastUsedRow(ws As Worksheet) As LongOn Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0
End Function

Call it at any time using e.g. [lastUsedRow(sheet1)]

 

[Padthelad]

ah yes, you're using column M to determine the end of the table. I hardly ever use this common approach, for me the following is a more robust solution, it considers the actual last used row of the whole worksheet - not just one column, it ignores "dead space" within the usedrange object, and returns 0 for empty sheets; it is also easy to use anywhere:

Function lastUsedRow(ws As Worksheet) As LongOn Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0
End Function

Call it at any time using e.g. [lastUsedRow(sheet1)]

Thank you for your comments.

I am afraid I am still having the same problem that all the data is not copied to the new workbook. Only the header and first line.

I also, don't quite understand 'function lastUsedRow' comment.

Sorry but do you have any further suggestions to solve my issue. I feel I am close....

Many thanks,

Patrick

 

[baitmaster]

There are several types of macro, you usually use Subs but you can also use Functions. Functions are very similar, but return a variable value to wherever the function was called from

So you can have a code module containing just the Function stated above, and then in a macro make your variable = the result from the function. In your example, rather than

LastRow = wb.Sheets("2016").Cells(Rows.Count, "A").End(xlUp).Row

I would write

LastRow = lastusedrow(wb)

this calls the function, passes the wb object into it, and assigns the result to the variable LastRow

Functions have further uses, in that they can be used to create your own spreadsheet formulas which you can use within cells. These are known as UDFs (user-defined functions) - for when you need something so specialised that standard formulas just can't hack it

 

[Padthelad]

There are several types of macro, you usually use Subs but you can also use Functions. Functions are very similar, but return a variable value to wherever the function was called from

So you can have a code module containing just the Function stated above, and then in a macro make your variable = the result from the function. In your example, rather than

LastRow = wb.Sheets("2016").Cells(Rows.Count, "A").End(xlUp).Row

I would write

LastRow = lastusedrow(wb)

this calls the function, passes the wb object into it, and assigns the result to the variable LastRow

Functions have further uses, in that they can be used to create your own spreadsheet formulas which you can use within cells. These are known as UDFs (user-defined functions) - for when you need something so specialised that standard formulas just can't hack it

Oh I see. This seems to be an asthetic issue to make the code look cleaner. I appreciate you informing and improving my understanding, however, I am still unable to have my code execute what I desire.

Do you have any further thoughts on why this VBA is not 'searching column C and copying the entire row to a new workbook if ' depsoit paid' is found'?

Many thanks,

Patrick

 

[baitmaster]

It's not just aesthetics, it's the best way to accurately identify the size of the used range of data on a worksheet, plus it's easier to work with and hence reduces potential for errors. There's a worksheet.usedrange object but it's prone to inaccuracy when data is deleted so I avoid it.

Did you follow the debugging steps I suggested? what happened, did the code go through the loops as expected or jump out unexpectedly?

Add the following lines and tell me what happens in the Immediate window once you've run your code:

    For Each Cell In cRange
       [COLOR=#FF0000]debug.print cell.address, cell.value[/COLOR]
        If Cell.Value = "deposit paid" Then
            [COLOR=#FF0000]debug.print "copying to row " & lastrow2[/COLOR]
            Cell.EntireRow.Copy
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlPasteFormats
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlValues
            LastRow2 = LastRow2 + 1
        [COLOR=#FF0000]else
            debug.print "not copied"[/COLOR]
        End If
    Next Cell

 

[Padthelad]

It's not just aesthetics, it's the best way to accurately identify the size of the used range of data on a worksheet, plus it's easier to work with and hence reduces potential for errors. There's a worksheet.usedrange object but it's prone to inaccuracy when data is deleted so I avoid it.

Did you follow the debugging steps I suggested? what happened, did the code go through the loops as expected or jump out unexpectedly?

Add the following lines and tell me what happens in the Immediate window once you've run your code:

    For Each Cell In cRange
       [COLOR=#FF0000]debug.print cell.address, cell.value[/COLOR]
        If Cell.Value = "deposit paid" Then
            [COLOR=#FF0000]debug.print "copying to row " & lastrow2[/COLOR]
            Cell.EntireRow.Copy
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlPasteFormats
            wb2.Sheets(1).Range("A" & LastRow2).PasteSpecial xlValues
            LastRow2 = LastRow2 + 1
        [COLOR=#FF0000]else
            debug.print "not copied"[/COLOR]
        End If
    Next Cell

Hi Bait,

Thank you for your response.

I did run through the debugging steps you suggested line by line using F8. As expected the code created the new sheet, then copied the headers and first line, but then continued through the loop without copying any of the data over.

I'm really confused as to why this wont work.

Sorry to be a pain.

Many thanks,

Pad

 

[Ingolf]

Try this code:

Sub CopyRows()
    
    Dim LR As Integer
    Dim wb As Workbook, wb2 As Workbook
    Set wb = ActiveWorkbook
    Set wb2 = Workbooks.Add
    Application.ScreenUpdating = False
    LR = wb.Sheets("2016").Range("A" & Rows.Count).End(xlUp).Row
    Dim rng As Range
    wb.Sheets("2016").Range("A1:M1").Copy wb2.Sheets(1).Range("A1")
    For Each rng In wb.Sheets("2016").Range("C2:C" & LR)
        If rng = "deposit paid" Then
            rng.EntireRow.Copy wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next rng
    wb2.Sheets(1).Columns.AutoFit   
    Application.ScreenUpdating = True
End Sub