CODEWITHSUNDEEP
vbaexcel
user5267576
user5267576

Reputation: 23

Search for item in workbook A, if found, copy row to workbook B

I need to copy from workbook A to B based on a search string. The searching part seems to be ok from debugging but the copying is not working. Is there something that i have done wrongly? 

    Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
lNextRow = 1
Set wbData = Application.Workbooks.Open(FileName, ReadOnly:=True)
ThisWorkbook.Activate
For Each ws In wbData.Worksheets
With ws
    For Each Cell In ws.Range("H:H")
        If Cell.Value = fWhat Then
            matchRow = Cell.Row
            'ws.Rows("8:" & matchRow).Select
            'Selection.Copy
            ws.Rows(matchRow, "8").Copy wsNewData.Rows(lNextRow)
            wsNewData.Select
            wsNewData.Rows(lNextRow).Select

            wsNewData.Paste
            lNextRow = lNextRow + 1
            wbThis.Save
        End If
    Next
End With
Next
wbData.Close

Upvotes: 0

Views: 87

Answers (2)

user4039065
user4039065

Reputation:

It looked like you were getting there but you had some methods mashed up and the copy seemed to be unclear as to the source and destinaton.

Dim wbThis As Workbook, wbData As Workbook
Dim ws As Worksheet, wsNewData As Worksheet
Dim cell As Range
Dim lNextRow As Long, matchRow As Long
Dim fWhat As String, fileName As String

fWhat = "thing to find"
fileName = Environ("TEMP") & Chr(92) & "myWorkBook.xlsb"

Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
Set wbData = Application.Workbooks.Open(fileName, ReadOnly:=True)

lNextRow = 1

For Each ws In wbData.Worksheets
    With ws
        For Each cell In Intersect(.UsedRange, .Range("H:H"))
            If cell.Value = fWhat Then
                matchRow = cell.Row
                .Rows(matchRow).Copy wsNewData.Rows(lNextRow).Cells(1)
                lNextRow = lNextRow + 1
                wbThis.Save
            End If
        Next cell
    End With
Next ws

wbData.Close SaveChanges:=False
Set wbThis = Nothing
Set wsNewData = Nothing
Set wbData = Nothing

I've used a full row copy from the worksheet being examined to the next row on the wsNewData worksheet (Sheet1 of wbThis).

When you are within a With ... End With statement, you do not have to keep referencing the object the With ... End With references. Just preceed the ranges/.Rows, etc with a period anf they will know that the parent worksheet is the only referenced by the With ... End With.

I also had to invent a fileName and fWhat to look for. You will need to set hose yourself.

Upvotes: 1

vacip
vacip

Reputation: 5416

Your code is redundant at some places. Though the biggest issue I think is going through every cell in the whole coloumn H, which takes a long time. Here is the code, cleaned up:

Set wbThis = ActiveWorkbook
Set wsNewData = wbThis.Sheets("Sheet1")
lNextRow = 1
Set wbData = Application.Workbooks.Open(FileName, ReadOnly:=True)
ThisWorkbook.Activate
For Each ws In wbData.Worksheets
  For Each Cell In intersect(ws.Range("H:H"),ws.usedrange)
    If Cell.Value = fWhat Then
        ws.Rows(Cell.Row).Copy wsNewData.Rows(lNextRow)
        lNextRow = lNextRow + 1
    End If
  Next
Next
wbThis.Save
wbData.Close 'you are closing this withouth saving. are you sure you want to do this???? just delete this line...

Another issue is that apparently you are really beginner in VBA, and in programming in general. Why don't you start with the macro recorder, and analyze the codes it records? Also, read up a bit on object oriented programming, and VBA too. I'm sorry, but I can't explain everything I did, sinece I think I'd have to start with Adam and Eve...

Hope this works.

Also, next time, just do an autofilter, and record it with macro recorder. Will even be faster than this.

Upvotes: 3

Related Questions