Copy rows to New Worksheet based on Condition!

Ammarbokhari · May 22, 2011

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.

Datsmart · May 23, 2011

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.

Ammarbokhari · May 23, 2011

Datsmart:

This code will copy all Rows from each worksheet that matches the listed criteria to the worksheet named "Summary".

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.

Ammarbokhari · May 23, 2011

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.

Datsmart · May 23, 2011

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.

Ammarbokhari · May 24, 2011

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.

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.

Datsmart · May 24, 2011

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".

Peter_SSs · May 24, 2011

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.

 Sub CopyToSummary() Dim wsS As Worksheet, ws As Worksheet Dim lr1 As Long, lr2 As Long, rws As Long, nr As Long, r As Long Const bhr As Long = 2 '<-- bottom header row Const Var1 As String = "Incomplete" '<- Change to suit Const myCol As String = "D" '<- Column to look for Var1 in Const HLCol As String = "I" '<- Hyperlink column Set wsS = Sheets("Summary") '<- Change to suit Application.ScreenUpdating = False For Each ws In Worksheets With ws If .Name <> wsS.Name Then lr1 = .Cells(.Rows.Count, myCol).End(xlUp).Row If lr1 > bhr Then nr = wsS.Range(myCol & wsS.Rows.Count).End(xlUp).Row + 1 With .Rows(bhr & ":" & lr1) .AutoFilter Field:=Columns(myCol).Column, Criteria1:=Var1 .Offset(1).Resize(.Rows.Count - 1).Copy _ Destination:=wsS.Cells(nr, 1) .AutoFilter End With lr2 = wsS.Range(myCol & wsS.Rows.Count).End(xlUp).Row If lr2 >= nr Then rws = lr2 - nr + 1 For r = 1 To rws wsS.Hyperlinks.Add _ Anchor:=wsS.Cells(nr + r - 1, HLCol), _ Address:="", SubAddress:="'" & .Name & "'!A1", _ TextToDisplay:=.Name Next r End If End If End If End With Next ws Application.ScreenUpdating = True End Sub

Ammarbokhari · May 24, 2011

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.

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

Peter_SSs · May 24, 2011

Ammarbokhari said:
This part of the code did not work properly

Code:

.Offset(1).Resize(.Rows.Count - 1).Copy _ Destination:=wsS.Cells(nr, 1)

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.

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

It's a bit daunting but hiker95 has compiled an extive list of resources:
http://www.mrexcel.com/forum/showthread.php?t=552206

Copy rows to New Worksheet based on Condition!

Ammarbokhari

Board Regular

Excel Facts

Datsmart

Well-known Member

Ammarbokhari

Board Regular

Ammarbokhari

Board Regular

Datsmart

Well-known Member

Ammarbokhari

Board Regular

Datsmart

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

Ammarbokhari

Board Regular

Peter_SSs

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

Copy rows to New Worksheet based on Condition!

Board Regular

Excel Facts

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Well-known Member

MrExcel MVP, Moderator

Board Regular

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock