Copy and Paste from other Workbooks with conditions

[ATan]

I have a source workbook in ("S:\Infrastructure Section\Commercial Management\PMI and Claims\MBS-11-005a and 005b - Claims Registers Rev. 1-Infrastructure.xls") in a sheet named as "Clause 14". This workbook contains a massive amount of data which for my purpose I only needed only data from a few specific columns (Col A to F, S, T).
The target workbook is found in ("S:\Infrastructure Section\Commercial Management\PMI and Claims\INFRA-EOT Summary.xls") in a sheet named as "WP2047".
I need to extract from the source workbook all the data if column "A" starting from row 10 contain the value of "WP2407". So all rows will column A having the value of "2407" will be extracted to the target but only from the following columns, A to F, S, T starting from row 10. The data coming in from the source file will start at row 7 in the target file. I hope I a clear with what I am trying to get across. Please let me know if you need further clarification.

[MaximS]

you can use something like that:

 
Sub Copy_Paste()
Dim wb, wb1 As Workbook
Dim sh, sh1 As Worksheet
Set wb = Workbooks.Open("S:\Infrastructure Section\Commercial Management\" _
& "PMI and Claims\MBS-11-005a and 005b - Claims Registers Rev. 1-Infrastructure.xls")
Set sh = wb.Worksheets("Clause 14")
Set wb1 = Workbooks.Open("S:\Infrastructure Section\Commercial Management\" _ 
& "PMI and Claims\INFRA-EOT Summary.xls")
Set sh1 = wb1.Worksheets("WP2047") 
Dim i, LastRow As Long
Dim strx As String
With sh
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    j = 7
    For i = 10 To LastRow
        If .Cells(i, 1).Value = "WP2407" Then
             strx = sh.Range("A" & i).Value
             sh1.Range("A" & j).Value=Mid(strx, 3, 4)
            .Range("B" & i & ":F" & i).Copy Destination:= sh1.Range("B" & j & ":F" & j)
            .Range("S" & i & ":T" & i).Copy Destination:= sh1.Range("S" & j & ":T" & j)
            j = j + 1
        End If
    Next i
End With
End Sub

[ATan]

MaximS,

Thanks for the quick reply, I couldn't understand why I encountered an error while running the codes.
This is the error message "Runtime error '9'. Subscript out of range".

[MaximS]

i've changed the code so try again if it doesn't work copy the line where that error appears.

[ATan]

MaximS,

Sorry, I did not see the changes you said.

[MaximS]

copy and paste the code to your worksheet, then run the code again.

the part I have changed is:

from

 Set wb = Workbooks(".....")

to

 Set wb = Workbooks.Open(".....")

[ATan]

MaximS,

I have changed the codes as suggested but the same error message still appear but it did not indicate where the error is occurring. Secondly, the source file is opened by the codes.

[GTO]

MaximS,

I have changed the codes as suggested but the same error message still appear but it did not indicate where the error is occurring. Secondly, the source file is opened by the codes.

Greetings ATan,

Just curious, what workbook did you put Maxim's code in?

Mark

[MaximS]

have you pressed debug button?? if yes which line is highlighted on yellow.

[ATan]

In the worksheet called "WP2407" itself as I am running the codes from a button. Does this matter?

I put the codes into a module and the same error message still appear but highlight the error being here

Set wb1 = Workbooks("S:\Infrastructure Section\Commercial Management\" _
    & "PMI and Claims\INFRA-EOT Summary.xls")

[MaximS]

in that case change code to:

 
Sub Copy_Paste() 
Dim wb, wb1 As Workbook 
    Dim sh, sh1 As Worksheet 
Set wb1 = ActiveWorkbook
Set sh1 = wb1.Worksheets("WP2047") 
Set wb = Workbooks.Open("S:\Infrastructure Section\Commercial Management\" _ 
    & "PMI and Claims\MBS-11-005a and 005b - Claims Registers Rev. 1-Infrastructure.xls") 
Set sh = wb.Worksheets("Clause 14") 
Dim i, LastRow As Long 
    Dim strx As String 
With sh 
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row 
j = 7 
For i = 10 To LastRow 
            If .Cells(i, 1).Value = "WP2407" Then 
                strx = sh.Range("A" & i).Value 
                sh1.Range("A" & j).Value=Mid(strx, 3, 4) 
                .Range("B" & i & ":F" & i).Copy Destination:= sh1.Range("B" & j & ":F" & j) 
                .Range("S" & i & ":T" & i).Copy Destination:= sh1.Range("S" & j & ":T" & j) 
                j = j + 1 
            End If 
        Next i 
    End With 
End Sub

and try again

[ATan]

MaximS,

With the new codes the error message shows up this part of the code is having the problem.

The codes are in a module.

Set sh1 = wb1.Worksheets("WP2047")

[GTO]

@Maxims:

Just wanted to say Howdy and forgot to :-)

Mark

[ATan]

GTO,

Hi! Thanks for dropping into this thread. So far no luck in getting the codes to work the way it suppose to be.

[ATan]

MaximS,

A Thousand apology. I spotted the error. The Sheet name should be WP2407 instead of WP2047. The code is running but one question. Why is the source workbook open after the data is copied over? How to close it after the data are copied?

[MaximS]

replace:

 
Next i 
End With

with:

 
Next i
.Close
End With

[ATan]

MaximS,

Appreciate very much your help to get this macro working. I have made some minor changes after successfully running the codes. These are the changes made as I wanted to line the data consecutively.

.Range("S" & i & ":T" & i).Copy Destination:= sh1.Range("S" & j & ":T" & j

to

.Range("S" & i & ":T" & i).Copy Destination:=sh1.Range("G" & j & ":H" & j)