• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Excel to copy matching cell row from tabs to a summary tab in the same workbook

C

Clarkinkent

New Member
I have a workbook and I need to find the NO values on ROW G (Row 7) and then copy the line that NO belongs to a new sheet (TAB) called summary, in my case it is listed as sheet 18.

I need to search on all sheets though from Sheet 1 to Sheet 17 in their G Rows for NO's.

I have a code I have found online and amend it to work with my criteria. But it does not seem to work as I would like it to it keeps coming up with errors.


Option Explicit
PrivateSub Worksheet_Change(ByVal Target As Range)Dim nxtRow AsInteger`enter code here`'Determine if change was to Column G (7)If Target.Column =7Then'If Yes, Determine if cell = NOIf Target.Value ="NO"Then'If Yes, find next empty row in Sheet 18
nxtRow = Sheets(18).Range("F"& Rows.Count).End(xlUp).Row +1'Copy changed row and paste into Sheet 18
Target.EntireRow.Copy _
Destination:=Sheets(18).Range("A"& nxtRow)EndIfEndIfEndSub



Thank you in advance. Vasilis.



 
Hi,

Welcome to Chandoo.org forum.

The codes pasted and the one in the snapshot are not matching. The pasted code is sheet based event which will fire only if a cell is changed. The screenshot code needs to be run manually.

Do you want to copy (not cut) only? It will be troublesome if someone runs such macro more than one times in case of copy+paste job!

Instead of uploading images you can upload workbook as that can help test people quickly e.g. The tab name you have described is "Summary" and in snapshot it is "Summary Page".
 
Hello Shrivallabna

Thank you for your response.
I do not mind if the summary page is wiped clean at the beggining of the run, so the results are fresh.

Indeed I want a copy not cut. As the summary if for reporting purposes, a quick look for not completed, everything with NO across several sheets.

Indeed the code on the screenshot is from my experiments to make it run.
When I copied and paste it in the coding of a sheet, I could not see any run command at all.
So if I was creating it as a module it would have the run command, but it comes back with compiler errors.
 

Attachments

  • List.xlsm
    22.7 KB · Views: 4
Is this how you wanted?
Code: 
Sub test()
    Dim ws As Worksheet, flg As Boolean
    Sheets("summary page").Cells.Clear
    For Each ws In Worksheets
        If Not ws Is Sheets("summary page") Then
            With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy Sheets("summary page").Cells(1): flg = True
                Else
                    .Offset(1).Copy Sheets("summary page").Range("a" & Rows.Count).End(xlUp)(2)
                End If
                .AutoFilter
            End With
        End If
    Next
End Sub
 
jindon said:
Is this how you wanted?
Code: 
Sub test()
    Dim ws As Worksheet, flg As Boolean
    Sheets("summary page").Cells.Clear
    For Each ws In Worksheets
        If Not ws Is Sheets("summary page") Then
            With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy Sheets("summary page").Cells(1): flg = True
                Else
                    .Offset(1).Copy Sheets("summary page").Range("a" & Rows.Count).End(xlUp)(2)
                End If
                .AutoFilter
            End With
        End If
    Next
End Sub
Click to expand...

Hi Jindon,

Yeah this works fantastic.

I need to edit it so it will olny copy the values and not the formatting.
Any ideas on what I need to amend below?

I have made it like this for now as it will put the last time the summary was ran on I1 cell.

Code: 
Sub summary()
'
' summary Macro
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Range("A2:H3000").Select
    Selection.ClearContents
    Range("J1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select



    Dim ws As Worksheet, flg As Boolean
    For Each ws In Worksheets
        If Not ws Is Sheets("summary") Then
            With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy Sheets("summary").Cells(1): flg = True
                Else
                    .Offset(1).Copy Sheets("summary").Range("a" & Rows.Count).End(xlUp)(2)
                End If
                .AutoFilter
            End With
        End If
    Next
End Sub

PS really sorry, but I have not done programming for 18 years more less, last time was Cobol, bit of C+ and Pascal back in the university years lol... it is hard to get back into it.
 
Change
Code: 
           With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
               IfNot flg Then
                    .Copy Sheets("summary").Cells(1): flg = True
               Else
                    .Offset(1).Copy Sheets("summary").Range("a" & Rows.Count).End(xlUp)(2)
               EndIf
                .AutoFilter
           End With
to
Code: 
            With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy
                    Sheets("summary page").Cells(1).PasteSpecial -4163: flg = True
                Else
                    .Offset(1).Copy
                    Sheets("summary page").Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial -4163
                End If
                .AutoFilter
            End With
 
jindon said:
Change
Code: 
           With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
               IfNot flg Then
                    .Copy Sheets("summary").Cells(1): flg = True
               Else
                    .Offset(1).Copy Sheets("summary").Range("a" & Rows.Count).End(xlUp)(2)
               EndIf
                .AutoFilter
           End With
to
Code: 
            With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy
                    Sheets("summary page").Cells(1).PasteSpecial -4163: flg = True
                Else
                    .Offset(1).Copy
                    Sheets("summary page").Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial -4163
                End If
                .AutoFilter
            End With
Click to expand...

It works partially, but still copies the text formatting, ie the bold or italic.
But it does not copy the cell fill colour anymore.
 
I got it working :)

Code: 
                With ws.Cells(1).CurrentRegion
                .AutoFilter 7, "no"
                If Not flg Then
                    .Copy
                    Sheets("summary").Cells(1).PasteSpecial Paste:=xlPasteValues: flg = True
                Else
                    .Offset(1).Copy
                    Sheets("summary").Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If
                .AutoFilter
            End With
 
Because the cell format in "summary..." sheet remains.
Delete the cells in summary sheet once then run the code, so that it only keep the cell format that you cutomize like header row, if you like.
 
jindon said:
Because the cell format in "summary..." sheet remains.
Delete the cells in summary sheet once then run the code, so that it only keep the cell format that you cutomize like header row, if you like.
Click to expand...
Yes I have done that, but it still copied over some bold font cells, I do not know why.
With the last code revision is now sorted :) thank you so much.

It saved me so much time as the only other option I had was to record all the steps manually with Macro record... it would have taken for ever!!
 
You must log in or register to reply here.
Back
Top