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.




B
C
D
E
F
G
H
I
J
K
L
M
N
1
Number
TB
Date
Name
TB Type
Tel Number
Email
Address
Source
Entered By
Visit Date
Quote Sent
Price
2
1348
TB
02/07/2016
Test1
Badminton
12345
Test1@test
123 Testing
Yard
PD


2
1349

TB
02/07/2016
Test2
Windsor

6789
Test2@test
1234 Testing
Yard
PD


2
1350

TB
03/07/2016
Test3
Flimwell
101112
Test3@test
12345 Testing
Yard
PD


2
1351
TB
04/07/2016
Test4
Cowbeech
131415
Test4@test
123456 Testing
Yard
PD


3












4












5













<tbody>
</tbody>

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

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
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.



BCDEFGHIJKLMN
1Number
TB
Date
Name
TB Type
Tel Number
Email
Address
Source
Entered By
Visit Date
Quote Sent
Price
21348TB02/07/2016Test1Badminton12345Test1@test123 TestingYardPD
21349
TB02/07/2016Test2Windsor
6789Test2@test1234 TestingYardPD
21350
TB03/07/2016Test3Flimwell101112Test3@test12345 TestingYardPD
21351TB04/07/2016Test4Cowbeech131415Test4@test123456 TestingYardPD
3
4
5

<tbody>
</tbody>

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
194
sspatriots
S
S
  • Question
Creating new sheets from template sheet plugging data into new sheets with particular criterias
Replies
1
Views
80
mumps
mumps
M
  • Question
VBA help required in creating multiple workbooks from one workbook.
Replies
5
Views
320
jolivanes
jolivanes
S
  • Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
355
sspatriots
S
N
  • Question
Double Click Macro that creates new sheet using SQL query
Replies
1
Views
146
Fluff
Fluff

Forum statistics

Threads
1,215,494
Messages
6,125,139
Members
449,207
Latest member
VictorSiwiide

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