Copy rows to New Worksheet based on Condition!

A

Ammarbokhari

Board Regular
Joined
Apr 21, 2011
Messages
55
Hi Everyone,
I am trying to copy all the rows in different worksheets present in a single workbook based on condition (incomplete) in Cell D, I found this code on this forum but it only copies from the active worksheet not from the rest of workbook.
Please help me with it.

'this will put your data in a new worksheet
'it will also Auto fits text in Columns on the new sheet
Sub Extract_Data_Two()
Application.ScreenUpdating = False
Dim FilterCriteria
Dim CurrentsheetName As String
Dim NewFileName As String
'Get the current sheets's name
CurrentsheetName = ActiveSheet.Name
'Select the range
'(note you can change this to meet your requirements)
Range("A1:AS3000").Select
'Apply Autofilter
Selection.AutoFilter
'Get the filter's criteria from the user
FilterCriteria = "Incomplete"
'Filter the data based on the user's input
'NOTE - this filter is on column D (field:=4), to change
'to a different column you need to change the field number
Selection.AutoFilter field:=4, Criteria1:=FilterCriteria
'Select the visible cells (the filtered data)
Selection.SpecialCells(xlCellTypeVisible).Select
'Copy the cells
Selection.Copy
Sheets.Add
'Make sure you are in cell A1
Range("A1").Select
'Paste the copied cells
ActiveSheet.Paste
'Clear the clipboard contents
Application.CutCopyMode = False
' Auto fits text in Columns
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
'Go back to the original sheet
Worksheets(CurrentsheetName).Activate
'Clear the autofilter
Selection.AutoFilter field:=1
'Take the Autofilter off
Selection.AutoFilter
'Go to A1
Range("A1").Select
Application.ScreenUpdating = True
End Sub


Thank You.
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
This code will copy all Rows from each worksheet that matches the listed criteria to the worksheet named "Summary".
Code: 
Sub Copy2Summary()
Dim LastRowS As Long
Dim LastRowT As Long
'Assign variables for Current Sheet, Target Sheet and search string
    cs = ActiveSheet.Name
    ts = "Summary"
    Var1 = "Incomplete"
'Loop through all worksheets except listed
    For Each wks In ActiveWorkbook.Worksheets
        'Do this for all sheets except these
        Select Case wks.Name
            Case ts, "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"
                'do nothing with the above worksheets
            Case Else
                'With worksheets not listed, do the following...
                With wks
                    Sheets(wks.Name).Activate
                    LastRowS = Cells(Rows.Count, 4).End(xlUp).Row
                    Set Source = Range("D1:D" & LastRowS)
                        For Each c In Source
                            If c.Value = Var1 Then
                                'Copy Rows that meet Criteria
                                LastRowT = Sheets(ts).Cells(Sheets(ts).Rows.Count, 1).End(xlUp).Row + 1
                                c.EntireRow.Copy Destination:=Sheets(ts).Range("A" & LastRowT)
                            End If
                        Next c
                End With
        End Select
    Next wks
    Sheets(cs).Activate 'Return to Current Worksheet when done
    'Clear memory
    Set Source = Nothing
End Sub
Code will not copy from the worksheets that have their names listed in the code. Adjust sheetnames as desired.
 
Upvote 0
Datsmart:
This code will copy all Rows from each worksheet that matches the listed criteria to the worksheet named "Summary".
Click to expand...

Thank you, the code works perfectly. Can a hyperlink be added to each sheet displaying sheet name in column I of the Summary Sheet, so that all the searched rows show the name of source worksheet and we can jump to it if required.

Thank you for your time.
 
Upvote 0
Hi,
There is one more small thing, I can't seem to add header into Summary sheet as the code pastes the values in the second row onwards in the Summary Sheet.

Thank you for you time.
 
Upvote 0
Code: 
Sub Copy2Summary2()
Dim LastRowS As Long
Dim LastRowT As Long
'Assign variables for Current Sheet, Target Sheet and search string
    cs = ActiveSheet.Name
    ts = "Summary"
    Var1 = "Incomplete"
'Loop through all worksheets except listed
    For Each wks In ActiveWorkbook.Worksheets
        'Do this for all sheets except these
        Select Case wks.Name
            Case ts, "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5"
                'do nothing with the above worksheets
            Case Else
                'With worksheets not listed, do the following...
                With wks
                    Sheets(wks.Name).Activate
                    LastRowS = Cells(Rows.Count, 4).End(xlUp).Row
                    Set Source = Range("D1:D" & LastRowS)
                        For Each c In Source
                            If c.Value = Var1 Then
                                'Copy Rows that meet Criteria
                                LastRowT = Sheets(ts).Cells(Sheets(ts).Rows.Count, 1).End(xlUp).Row + 1
                                c.EntireRow.Copy Destination:=Sheets(ts).Range("A" & LastRowT)
                                Sheets(ts).Range("I" & LastRowT).Value = wks.Name
                                ActiveSheet.Hyperlinks.Add Anchor:=Sheets(ts).Range("I" & LastRowT), Address:="", SubAddress:= _
                                wks.Name & "!A1", TextToDisplay:=Sheets(ts).Range("I" & LastRowT).Value
                            End If
                        Next c
                End With
        End Select
    Next wks
    Sheets(cs).Activate 'Return to Current Worksheet when done
    'Clear memory
    Set Source = Nothing
End Sub
Lines added to create your Hyperlink.
As far as values being input into the second row onwards, the code has to do that so as not to over-write existing data. You can paste a header row there if you want to.
 
Upvote 0
Datsmart said:
Lines added to create your Hyperlink.
As far as values being input into the second row onwards, the code has to do that so as not to over-write existing data. You can paste a header row there if you want to.
Click to expand...
Hi Mr. John,
Thank you very much for your time and support.
Well there are still two minor issues.
Hyperlink to sheets with space in their names don't work while they work fine with sheets without space in their names (I have tried by removing space and it works for those sheets for which it was not working already)
Secondly, I have two rows of header with a few merged cells and I dont get the proper results in Summary sheet. Without header macro works fine.
Hoping to get this resolved :-)
Thank you again.
 
Upvote 0
Don't have a solution for you with worksheet names with spaces. I never use them, old habits from my DOS days where they were not allowed.

Merged cells and macros have many problems. Best not to use them if you want to automate things. You can get the same result using the format "center across selection".
 
Upvote 0
I think you should be able to get the same results without looping through each row of each sheet so I have suggested some new code.

My assumptions are
- that you have 2 rows of headers on each sheet, including a Summary sheet that already exists.
- that you don't need the sheet exclusion list since you did not appear to mention other sheets to exclude, apart from the Summary sheet itself.

Adding hyperlinks is definitely not my strongest point so there may be a better way to add them but I hope this does what you want.

Test in a copy of your workbook.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> CopyToSummary()<br>    <SPAN style="color:#00007F">Dim</SPAN> wsS <SPAN style="color:#00007F">As</SPAN> Worksheet, ws <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> lr1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lr2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, nr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>        <br>    <SPAN style="color:#00007F">Const</SPAN> bhr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = 2 <SPAN style="color:#007F00">'<-- bottom header row</SPAN><br>    <SPAN style="color:#00007F">Const</SPAN> Var1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "Incomplete" <SPAN style="color:#007F00">'<- Change to suit</SPAN><br>    <SPAN style="color:#00007F">Const</SPAN> myCol <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "D" <SPAN style="color:#007F00">'<- Column to look for Var1 in</SPAN><br>    <SPAN style="color:#00007F">Const</SPAN> HLCol <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "I" <SPAN style="color:#007F00">'<- Hyperlink column</SPAN><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> wsS = Sheets("Summary") <SPAN style="color:#007F00">'<- Change to suit</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> ws <SPAN style="color:#00007F">In</SPAN> Worksheets<br>        <SPAN style="color:#00007F">With</SPAN> ws<br>            <SPAN style="color:#00007F">If</SPAN> .Name <> wsS.Name <SPAN style="color:#00007F">Then</SPAN><br>                lr1 = .Cells(.Rows.Count, myCol).End(xlUp).Row<br>                <SPAN style="color:#00007F">If</SPAN> lr1 > bhr <SPAN style="color:#00007F">Then</SPAN><br>                    nr = wsS.Range(myCol & wsS.Rows.Count).End(xlUp).Row + 1<br>                    <SPAN style="color:#00007F">With</SPAN> .Rows(bhr & ":" & lr1)<br>                        .AutoFilter Field:=Columns(myCol).Column, Criteria1:=Var1<br>                        .Offset(1).Resize(.Rows.Count - 1).Copy _<br>                            Destination:=wsS.Cells(nr, 1)<br>                        .AutoFilter<br>                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>                    lr2 = wsS.Range(myCol & wsS.Rows.Count).End(xlUp).Row<br>                    <SPAN style="color:#00007F">If</SPAN> lr2 >= nr <SPAN style="color:#00007F">Then</SPAN><br>                        rws = lr2 - nr + 1<br>                        <SPAN style="color:#00007F">For</SPAN> r = 1 <SPAN style="color:#00007F">To</SPAN> rws<br>                            wsS.Hyperlinks.Add _<br>                                Anchor:=wsS.Cells(nr + r - 1, HLCol), _<br>                                Address:="", SubAddress:="'" & .Name & "'!A1", _<br>                                TextToDisplay:=.Name<br>                        <SPAN style="color:#00007F">Next</SPAN> r<br>                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> ws<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>
 
Upvote 0
Peter_SSs said:
I think you should be able to get the same results without looping through each row of each sheet so I have suggested some new code.

My assumptions are
- that you have 2 rows of headers on each sheet, including a Summary sheet that already exists.
- that you don't need the sheet exclusion list since you did not appear to mention other sheets to exclude, apart from the Summary sheet itself.

Adding hyperlinks is definitely not my strongest point so there may be a better way to add them but I hope this does what you want.

Test in a copy of your workbook.
Click to expand...
This part of the code did not work properly
Code: 
.Offset(1).Resize(.Rows.Count - 1).Copy _
                            Destination:=wsS.Cells(nr, 1)
and also the problem persists with hyperlink.
Can you guide me to some books where I can learn excel VBA basics
Thank you very much for your help
 
Upvote 0
Ammarbokhari said:
This part of the code did not work properly
Code: 
.Offset(1).Resize(.Rows.Count - 1).Copy _
                            Destination:=wsS.Cells(nr, 1)
Click to expand...
In what way did it not work correctly?

Were my assumptions correct?

What version of Excel are you using?


Ammarbokhari said:
and also the problem persists with hyperlink.
Click to expand...
You mean not working with sheet names with spaces? That worked fine in my test worknbook.



Ammarbokhari said:
Can you guide me to some books where I can learn excel VBA basics
Thank you very much for your help
Click to expand...
It's a bit daunting but hiker95 has compiled an extive list of resources:
http://www.mrexcel.com/forum/showthread.php?t=552206
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
AutoFilter Field Macro Returns a Header Row only
2
Replies
11
Views
212
MARK858
MARK858
I
  • Question Question
Filter column on text value if that value exists using VBA
Replies
7
Views
386
Peter_SSs
Peter_SSs
S
  • Question Question
Change macro range from column A to B
2
Replies
10
Views
138
sachin483
S
S
  • Solved
Return error if "Filter" doesn't return the required entry
Replies
2
Views
169
skittlz
S
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
86
vanessavalentino83
V

Forum statistics

Threads
1,224,620
Messages
6,179,928
Members
452,949
Latest member
beartooth91

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