VBA Copy/Paste Loop or Filter Copy/Paste? Wherever “A:A” value equals Cell “XX” value

[Obbsie]

I am very new to VBA, been teaching myself and maybe asking something quite basic. I apologise if this is the case, but I haven't come across anything yet that I can tweek to my needs.

Here's what I'm looking to do (I'm using specific cell references):

For every instance where a cell in SourceWorkbook "A10:A40000" is equal to the value of SourceWorkbook "E7", copy cells in that row from column "C:J" and paste into relevant number of rows within DestinationWorkbook range "C18:J37" (there will never be more than 20 results).

From what I can gather there are a couple of paths the code could go down -

1 - After opening source doc, filter column "A" to equal value of "E7" then copy/paste values of required results into destination doc from "C18" onwards, or

2 - Creating a loop that looks for first instance of "E7" value in "A", copy/paste that row from "C:J" into next blank row within destination doc range "C18:J37", repeat for each instance

The "filtering" option would appear the simplest method, but unfortunately I don't know how to write either. Any help would be greatly appreciated. Thank you.

 

[dmt32]

Hi have a play with this & see if goes in direction you want.
I went for loop option as said only copying max 20 rows.

I have included some error checking but you will need to change values shown in red & make other changes as required.
Place code in standard module.

Sub CopySourceData()
    Dim LastRow As Long, r As Long
    Dim c As Range
    Dim wbSource As Workbook
    Dim wsDestination As Worksheet
    Dim sPath As String, sFileName As String
    Dim wsSource As String
    '*********************************************************
    '*************Change Values Below As Required*************
    'Source path
    sPath = "C:\Test\"
    'Source filename
    sFileName = "Test.xls"
    'source worksheet name
    wsSource = "Source"
    'destination worksheet
    Set wsDestination = ThisWorkbook.Worksheets("Destination")
    '**********************************************************
    '**********************************************************
    With wsDestination
        r = .Range("C" & .Rows.Count).End(xlUp).Row + 1
    End With
    If r < 18 Then r = 18
    
    'make sure Path / File exists
    If Not Dir(sPath & sFileName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        On Error GoTo myerror
        Set wbSource = Workbooks.Open(sPath & sFileName, ReadOnly:=True)
        With wbSource.Worksheets(wsSource)
            LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
            For Each c In .Range("A10:A" & LastRow)
                If c.Value = .Range("E7").Value Then
                    .Range(.Cells(c.Row, 3), .Cells(c.Row, 10)).Copy wsDestination.Cells(r, 3)
                    r = r + 1
                End If
            Next c
        End With
        wbSource.Close False
    Else
        MsgBox "File / Path Not Found", 16, "Error"
    End If
myerror:
    Application.ScreenUpdating = True
    If Err > 0 Then
        MsgBox (Error(Err)), 16, "Error"
        If Not wbSource Is Nothing Then wbSource.Close False
    End If
End Sub

Hope helpful

Dave

 

[Obbsie]

Thanks for your suggestion Dave, but I had a fiddle around before seeing your post and managed to write something that seems to work for me. It probably has a few unnessecary lines, but it does the trick.

Sub SearchForDocs()
Application.ScreenUpdating = False
On Error GoTo ErrMsg
Sheets("RetrievalForm").Select
Range("C18:J20").ClearContents
Range("C7").Copy
Workbooks.Open Filename:= _
        "C:\Documents and Settings\fch31\Desktop\Central Storage\CSDB Macro Setup.xls", ReadOnly:=True
Sheets("Stored").Select
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:=Range("E1"), Operator:=xlAnd
Range("C9").Select
Range(Selection, ActiveCell.Offset(0, 7)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("CSDB Submission Macro Setup.xls").Activate
Sheets("RetrievalForm").Select
Range("C17").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Windows("CSDB Macro Setup.xls").Activate
ActiveWindow.Close savechanges:=False
Windows("CSDB Submission Macro Setup.xls").Activate
Range("C7").Select
Exit Sub
ErrMsg:
MsgBox ("There are no documents in storage for Client ID " & Range("C7") & ". If the Client ID is correct, please contact a Central Storage Officer for confirmation"), vbCritical, "No Documents Found"
Windows("CSDB Macro Setup.xls").Activate
Application.CutCopyMode = False
ActiveWindow.Close savechanges:=False
Windows("CSDB Submission Macro Setup.xls").Activate
Range("C7").Select
End Sub

Thanks again for your response though.