VBA - create new sheet and organise data

P

Padthelad

Board Regular
Joined
May 13, 2016
Messages
64
Office Version
  1. 2016
Platform
  1. Windows
Hi,

I am looking for VBA code to find a solution to a problem.

I have a master workbook with various ‘quote enquiries’. Usual things are included such as name, address, phone number, quote details. I also have a column that has the date a quote was sent (column M).

I would like a Macro that would search through the worksheet and create a new workbook with all the data from that row if column M is empty (quote sent column). Then organize from ‘oldest’ to ‘newest’.

Example of data below.



[TABLE="width: 785"]
<tbody>[TR]
[TD]
[/TD]
[TD]B
[/TD]
[TD]C
[/TD]
[TD]D
[/TD]
[TD]E
[/TD]
[TD]F
[/TD]
[TD]G
[/TD]
[TD]H
[/TD]
[TD]I
[/TD]
[TD]J
[/TD]
[TD]K
[/TD]
[TD]L
[/TD]
[TD]M
[/TD]
[TD]N
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Number
[/TD]
[TD]TB
[/TD]
[TD]Date
[/TD]
[TD]Name
[/TD]
[TD]TB Type
[/TD]
[TD]Tel Number
[/TD]
[TD]Email
[/TD]
[TD]Address
[/TD]
[TD]Source
[/TD]
[TD]Entered By
[/TD]
[TD]Visit Date
[/TD]
[TD]Quote Sent
[/TD]
[TD]Price
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]1348
[/TD]
[TD]TB
[/TD]
[TD]02/07/2016
[/TD]
[TD]Test1
[/TD]
[TD]Badminton
[/TD]
[TD]12345
[/TD]
[TD]Test1@test
[/TD]
[TD]123 Testing
[/TD]
[TD]Yard
[/TD]
[TD]PD
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]1349

[/TD]
[TD]TB
[/TD]
[TD]02/07/2016
[/TD]
[TD]Test2
[/TD]
[TD]Windsor

[/TD]
[TD]6789
[/TD]
[TD]Test2@test
[/TD]
[TD]1234 Testing
[/TD]
[TD]Yard
[/TD]
[TD]PD
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]1350

[/TD]
[TD]TB
[/TD]
[TD]03/07/2016
[/TD]
[TD]Test3
[/TD]
[TD]Flimwell
[/TD]
[TD]101112
[/TD]
[TD]Test3@test
[/TD]
[TD]12345 Testing
[/TD]
[TD]Yard
[/TD]
[TD]PD
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]1351
[/TD]
[TD]TB
[/TD]
[TD]04/07/2016
[/TD]
[TD]Test4
[/TD]
[TD]Cowbeech
[/TD]
[TD]131415
[/TD]
[TD]Test4@test
[/TD]
[TD]123456 Testing
[/TD]
[TD]Yard
[/TD]
[TD]PD
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
</tbody>[/TABLE]

So in summary, I am looking for VBA code that will search the entire worksheet and create a new workbook with all the data from the corresponding row if column M is empty (i.e no quote has been sent). I would like this to then be organised in date order (column D).

I t would be good to be able to run this Macro at the beginning of each day so that I can see any outstanding quotes that need to be sent.

Any help anyone can provide is very much appreciated. I have been looking for various codes for a week now but still can figure what I need.

Thank you in advance.

Pad
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Do you want this in a new Sheet within your current workbook or a totally new workbook?
 
Upvote 0
Padthelad said:
Hi,

I am looking for VBA code to find a solution to a problem.

I have a master workbook with various ‘quote enquiries’. Usual things are included such as name, address, phone number, quote details. I also have a column that has the date a quote was sent (column M).

I would like a Macro that would search through the worksheet and create a new workbook with all the data from that row if column M is empty (quote sent column). Then organize from ‘oldest’ to ‘newest’.

Example of data below.



[TABLE="width: 785"]
<tbody>[TR]
[TD][/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Number
[/TD]
[TD]TB
[/TD]
[TD]Date
[/TD]
[TD]Name
[/TD]
[TD]TB Type
[/TD]
[TD]Tel Number
[/TD]
[TD]Email
[/TD]
[TD]Address
[/TD]
[TD]Source
[/TD]
[TD]Entered By
[/TD]
[TD]Visit Date
[/TD]
[TD]Quote Sent
[/TD]
[TD]Price
[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1348[/TD]
[TD]TB[/TD]
[TD]02/07/2016[/TD]
[TD]Test1[/TD]
[TD]Badminton[/TD]
[TD]12345[/TD]
[TD]Test1@test[/TD]
[TD]123 Testing[/TD]
[TD]Yard[/TD]
[TD]PD[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1349
[/TD]
[TD]TB[/TD]
[TD]02/07/2016[/TD]
[TD]Test2[/TD]
[TD]Windsor
[/TD]
[TD]6789[/TD]
[TD]Test2@test[/TD]
[TD]1234 Testing[/TD]
[TD]Yard[/TD]
[TD]PD[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1350
[/TD]
[TD]TB[/TD]
[TD]03/07/2016[/TD]
[TD]Test3[/TD]
[TD]Flimwell[/TD]
[TD]101112[/TD]
[TD]Test3@test[/TD]
[TD]12345 Testing[/TD]
[TD]Yard[/TD]
[TD]PD[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1351[/TD]
[TD]TB[/TD]
[TD]04/07/2016[/TD]
[TD]Test4[/TD]
[TD]Cowbeech[/TD]
[TD]131415[/TD]
[TD]Test4@test[/TD]
[TD]123456 Testing[/TD]
[TD]Yard[/TD]
[TD]PD[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

So in summary, I am looking for VBA code that will search the entire worksheet and create a new workbook with all the data from the corresponding row if column M is empty (i.e no quote has been sent). I would like this to then be organised in date order (column D).

I t would be good to be able to run this Macro at the beginning of each day so that I can see any outstanding quotes that need to be sent.

Any help anyone can provide is very much appreciated. I have been looking for various codes for a week now but still can figure what I need.

Thank you in advance.

Pad
Click to expand...
Hi Pad, is this any good to you?

Code: 
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("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Sheet1").Range("M2:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Sheet1").Range("A1:N1").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" Then
            Cell.EntireRow.Copy wb2.Sheets(1).Range("A" & LastRow2)
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If


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


End Sub
 
Upvote 0
Try this, I am sure there are better ways, but this worked great for me

Code: 
Sub Test()

Set wbCurrent = ThisWorkbook
Set wsCurrent = wbCurrent.ActiveSheet

Workbooks.Add

Set wbNew = ActiveWorkbook
Set wsNew = wbNew.Sheets(1)

wsNew.Rows(1) = wsCurrent.Rows(1).Value

lastRow = wsCurrent.Range("A" & Rows.Count).End(xlUp).Row

i = 2
j = 2

Do Until i > lastRow

    If IsEmpty(wsCurrent.Range("M" & i)) Then
        wsNew.Rows(j) = wsCurrent.Rows(i).Value
        j = j + 1
    End If
    i = i + 1
Loop

finalRow = wsNew.Range("A" & Rows.Count).End(xlUp).Row
 
    wsNew.Range("D2").Select
    wsNew.Sort.SortFields.Clear
    wsNew.Sort.SortFields.Add Key:=Range("D2:D" & finalRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:N" & finalRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
 
Last edited:
Upvote 0
Fishboy said:
Hi Pad, is this any good to you?

Code: 
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("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Sheet1").Range("M2:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Sheet1").Range("A1:N1").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" Then
            Cell.EntireRow.Copy wb2.Sheets(1).Range("A" & LastRow2)
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If


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


End Sub
Click to expand...

Hi Fishboy,

You're quickly becoming my savoir! Thank you! This seems to work almost perfectly!

Just two things:-

Is there a way to copy the formatting from the original sheet?
Can I also copy the headings to the new sheet? Currently the first three rows are the headings and they are frozen.

Thank you, thank you, thank you!

Please see amended code (I updated the sheet name)

Code: 
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("Main").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Main").Range("M2:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Main").Range("A1:N1").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" Then
            Cell.EntireRow.Copy wb2.Sheets(1).Range("A" & LastRow2)
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If


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


End Sub
 
Upvote 0
Padthelad said:
Hi Fishboy,

You're quickly becoming my savoir! Thank you! This seems to work almost perfectly!

Just two things:-

Is there a way to copy the formatting from the original sheet?
Can I also copy the headings to the new sheet? Currently the first three rows are the headings and they are frozen.

Thank you, thank you, thank you!

Please see amended code (I updated the sheet name)

Rich (BB code): 
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("Main").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Main").Range("M2:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Main").Range("A1:N1").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" Then
            Cell.EntireRow.Copy wb2.Sheets(1).Range("A" & LastRow2)
            LastRow2 = LastRow2 + 1
        End If
    Next Cell
End If


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


End Sub
Click to expand...
Hah! You're most welcome. In my original code I was only copying the first header row, but this has now been updated to copy the first 3 rows. It should also now copy the formatting across as well. Changes highlighted in red:

Rich (BB code): 
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("Main").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Main").Range("M4:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Main").Range("A1:N3").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" 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("D4:D" & LastRow2).Sort Key1:=Range("D4"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


End Sub
 
Upvote 0
Fishboy said:
Hah! You're most welcome. In my original code I was only copying the first header row, but this has now been updated to copy the first 3 rows. It should also now copy the formatting across as well. Changes highlighted in red:

Rich (BB code): 
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("Main").Cells(Rows.Count, "B").End(xlUp).Row
Set cRange = wb.Sheets("Main").Range("M4:M" & LastRow)


If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Main").Range("A1:N3").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" 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("D4:D" & LastRow2).Sort Key1:=Range("D4"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal


End Sub
Click to expand...


Fishboy, great once again!

This has thrown up another issue though. When I run the updated code, column B continues to 'count' indefinitely. I had to stop the code from running manually. On the original sheet this column is 'previous cell + 1' I can't identify the issue though.

Sorry to ask again, but one more try?

Thanks again,

Pad
 
Upvote 0
Padthelad said:
Fishboy, great once again!

This has thrown up another issue though. When I run the updated code, column B continues to 'count' indefinitely. I had to stop the code from running manually. On the original sheet this column is 'previous cell + 1' I can't identify the issue though.

Sorry to ask again, but one more try?

Thanks again,

Pad
Click to expand...
Hmm, in the original sheet does column B continue beyond where the rest of the data ends?
 
Upvote 0
Padthelad said:
Yes, it does.
Click to expand...
Ahh, right!

OK, so I have changed which column we use to find the "last row" of data from B to C. Try this:

Rich (BB code): 
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("Main").Cells(Rows.Count, "C").End(xlUp).Row
Set cRange = wb.Sheets("Main").Range("M4:M" & LastRow)

If Application.WorksheetFunction.CountIf(cRange, "") > 0 Then
    Set wb2 = Workbooks.Add
    wb.Sheets("Main").Range("A1:N3").Copy wb2.Sheets(1).Range("A1")
    LastRow2 = wb2.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    For Each Cell In cRange
        If Cell.Value = "" 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("D4:D" & LastRow2).Sort Key1:=Range("D4"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Define new table range
Replies
2
Views
399
sspatriots
S
N
  • Solved
VBA to select last 2 sheets created that are named in mm-dd-yy format
Replies
4
Views
132
Peter_SSs
Peter_SSs
S
  • Question Question
Create New Sheet with Specific Name Based on Variable Cell
Replies
0
Views
171
SBExcel123
S
O
  • Solved
VBA - Filter columns, cut/paste rows new sheet, pivot table
2
Replies
12
Views
261
Skyybot
Skyybot
E
  • Question Question
VBA - Create a new sheet + hyperlink name
Replies
3
Views
377
excelnewbie990
E

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top