copy row where cell has value > 0 2

[ragnarok75]

Excel XP
I need to create a macro that searches a column of data (Let's say A) in multiple worksheets (Sheet1, Sheet2, etc.). Where the column is greater than 0, the entire row is copied and pasted into the worksheet running the macro. How do I do this?

 

[VBAjedi]

Just off the top of my head, I'm thinking you could do something like:

Sub Test1()
Dim Wkbk1 As Workbook, Wkbk2 As Workbook
Dim DestSht As Worksheet, SrcSht As Worksheet
Dim OutputRow As Integer

Set Wkbk1 = ActiveWorkbook
Set Wkbk2 = Workbooks("MySourceWorkbookName") ' Need complete path here unless workbook is open
Set DestSht = Wkbk1.Worksheets("MyDestinationSheetName")
For Each SrcSht In Wkbk2.Worksheets ' Loop through all sheets in the workbook
    For x = 1 To SrcSht.Rows.Count
        If Sht.Range("A" & x).Value > 0 Then
            OutputRow = OutputRow + 1
            SrcSht.Range(x & ":" & x).Copy DestSht.Range("A" & OutputRow)
        End If
    Next x
Next Sht
End Sub

Play around with that. . . I didn't test it so there may be some minor syntax errors in there.

VBAjedi

 

[TonyJollans]

Hi ragnarok75,

From a quick glance Jedi's code looks good, except for the destination sheet. The sheet containing the code is not necessarily in the activeworkbook, but can easily be referenced using Me[/b}, so

[blue]Sub Test1()
:
:
Set DestSht = Me
For Each etc.
:
:
End Sub[/blue]

Enjoy,
Tony

--------------------------------------------------------------------------------------------
We want to help you; help us to do it by reading this: Before you ask a question.
Excel VBA Training and more Help at VBAExpress[

 

[KenWright]

Depending on how much data there is, would you not perhaps be better off having the code autofilter on >0 and then copying visible cells across rather than looping through each cell in each range.

Regards
Ken..........

----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission
----------------------------------------------------------------------------

 

[ragnarok75]

Thanks for everyone's replies - I will give the code a shot and post my results!!!

 

[ragnarok75]

Here is what I have found.

I can get the code to work, but the line

For x = 1 To SrcSht.Rows.Count

Sets the ending value to 65536 per sheet. This takes WAY too long.

Let me give more detail on what I am trying to do. I have a worksheet with 12 tabs. Each of those 12 tabs could have anywhere between 0 - 900 rows with data in them. I want to find the all the data which has a value > 0 entered in the first column on all these worksheets and copy it to the 12th worksheet (12th worksheet should not be included in the search for data). I agree with KenWright that it would be best to filter ColumnA on nonblank values and then copy the displayed data. It seems that would be much quicker.

After the data is populated in the 12th tab I want to save it to a seperate file (just the 12th tab) and attach it to an e-mail.

My code so far is this:

    Dim wkbk2 As Workbook
    Dim DestSht As Worksheet, srcsht As Worksheet
    Dim OutputRow As Integer
    
    Set Wbk2 = ActiveWorkbook
    Set DestSht = ActiveSheet
       
        For Each srcsht In Wbk2.Worksheets
            For x = 1 To SrcSht.Rows.Count
                If srcsht.Range("A" & x).Value > 0 Then
                    OutputRow = OutputRow + 1
                    srcsht.Range("A" & x).Copy DestSht.Range("A" & 7 + OutputRow)
                    srcsht.Range("D" & x & ":" & "I" & x).Copy DestSht.Range("C" & 7 + OutputRow)
                End If
            Next x
        Next

This works except that it takes too long because it searches rows 1 - 65536, it searches the 12th sheet, it does not autofilter. I am also copying and pasting a portion of the data as you can see above. I have not even tackled saving to a seperate file and e-mailing yet...

Any takers on this one?

 

[KenWright]

Try this for starters. Determine your last used row (Note, only works this way if you can rely on there being a value in Col A for the last used row)

LastRw = SrcSht.Cells(Rows.Count, "A").End(xlUp).Row

Then use that variable to set the range you want to query, Col A from first row to last used row:-

Set rng = SrcSht.Range(Cells(1, "A"), Cells(LastRw, "A"))

Then either loop through that as you were, or perhaps use Autofilter against that range, then use .SpecialCells(xlCellTypeVisible) to copy the required data and then paste where necessary.

Regards
Ken..........

----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission
----------------------------------------------------------------------------

 

[VBAjedi]

Sorry for thinking out loud here, but what about the VBA method for opening a workbook in "Read-only" mode? I'd think that would solve your issue. . . As I recall, it's the third argument for the Open command:

Set myWkbk = Workbooks.Open("myfilename",,ReadOnly)

Let me know if that does it for you. . .


VBAjedi

 

[ragnarok75]

The workbook is already read-only. That's why the changes which are copied to the last tab need to be saved to a seperate file.

 

[ragnarok75]

The LastRw suggestion from Ken works, however I think I may have placed it in the wrong place - Here is the code, the issue is that the If statement never gets ran.

    Dim wkbk2 As Workbook
    Dim DestSht As Worksheet, srcsht As Worksheet
    Dim OutputRow As Integer
    
    Set Wbk2 = ActiveWorkbook
    Set DestSht = ActiveSheet
       
        For Each srcsht In Wbk2.Worksheets
           LastRw = srcsht.Cells(Rows.Count, "A").End(xlUp).Row
             For x = 1 To x = LastRw
                 If srcsht.Range("A" & x).Value > 0 Then
                     OutputRow = OutputRow + 1
                     srcsht.Range("A" & x).Copy DestSht.Range("A" & 7 + OutputRow)
                     srcsht.Range("D" & x & ":" & "I" & x).Copy DestSht.Range("C" & 7 + OutputRow)
                 End If
             Next x
        Next

 

[KenWright]

Untested but try this:-

Option Explicit

Sub xxx()

    Dim Wbk2   As Workbook
    Dim DestSht As Worksheet, Srcsht As Worksheet
    Dim OutputRow As Integer

    Set Wbk2 = ActiveWorkbook
    Set DestSht = ActiveSheet

    For Each Srcsht In Wbk2.Worksheets
        If Srcsht.Name <> DestSht.Name Then
            LastRw = Srcsht.Cells(Rows.Count, "A").End(xlUp).Row
            For x = 1 To LastRw
                If Srcsht.Range("A" & x).Value > 0 Then
                    OutputRow = OutputRow + 1
                    Srcsht.Range("A" & x).Copy _
                       DestSht.Range("A" & 7 + OutputRow)
                    Srcsht.Range("D" & x & ":" & "I" & x).Copy _
                       DestSht.Range("C" & 7 + OutputRow)
                End If
            Next x
        End If
    Next

End Sub

Note you have incorrectly dimmed your inital variable for wkbk2. Option Explicit would have picked this up. Also, note the For x = ..... syntax change to what you had.

Lastly, I think it would be far quicker probably to run through each sheet, determine the last row and then copy the lot to a summary sheet. Do this for each sheet so you have ALL the data on the summary sheet, then just filter on all records = 0 and then delete using the specialcells method I referred to earlier.

----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission
----------------------------------------------------------------------------

 

[ragnarok75]

OK - Made some changes to the code and everything seems to be working.

The only issue I have now is that the final sheet is being queried which duplicates the data. The final sheet, sheet12 should not be included in copying data, only pastng data. Is there another way to do this so that sheet12 is excluded?

 

[KenWright]

I hadn't tested it but did you use something along the lines of the IF statement i put in there to try and trap that

If Srcsht.Name <> DestSht.Name Then


----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission
----------------------------------------------------------------------------

 

[ragnarok75]

Sorry fo rnot posting back, but Ken's last psot did the trick!! Thanks to everyone who helped!