Copy column based on partial word match in first row and paste into existing workbook

[David Harris 1987]

Hello friends,

This is my first post, but I have been a member of xl help forum for a long time, slowly learning VBA by picking up and understanding chunks of code.
I have recently written some code with the little knowledge I have to open an existing workbook, extract a column range and paste it into a seperate workbook.
I am looking to take this a step further by using text fragments to select, copy and paste individual columns, which meet the text criteria into a new workbook where the data can be analysed.
Essentially I am aiming to interrogate and extract information from a master workbook into a seperate but existing workbook and have the columns pasted so they are next to eachother.
At the moment my code looks like this:

Sub COPYCELL()

Dim wbk As Workbook
Dim i As Integer

strFirstFile = "C:\Workbook1.xlsx"
strSecondFile = "C:\workbook2.xlsx"

Set wbk = Workbooks.Open(strFirstFile)
With wbk.Sheets("Master Sheet")
For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If Application.CountIf(Columns(i), "*Total*") = 1 Then
Columns(i).Copy
End If
Next i
End With

Set wbk = Workbooks.Open(strSecondFile)
With wbk.Sheets("Sheet1")
Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub

The problem I am having is that it will only copy and paste the first row before cutting out.
Ideally it would be good to have a loop offset that would perform the task until the activecell becomes blank or up to a specified column range such as ZZ1.

The original code I used for a basic range copy operation looked like this:

Dim wbk As Workbook

intFirstFile = "C:\Workbook1.xlsx.xlsx"
intSecondFile = "C:\Workbook2.xlsx.xlsx"

Set wbk = Workbooks.Open(intFirstFile)
With wbk.Sheets("Master Sheet")
Range("G1:G1000").Copy
End With

Set wbk = Workbooks.Open(intSecondFile)
With wbk.Sheets("Sheet1")
Range("G1:G1000").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With

End Sub

Your help would be very greatly appreciated.
Thank you very much,

Dave

[JOHN H. DAVIS]

Maybe:

Please Login or Register  to view this content.

Not sure this does what you want, so try on a copy first.

[David Harris 1987]

Hi John,

I gave this a shot on a test sheet and got the following error message:

Run time error 9
Subscript out of range.

Here is the script I used, slightly adapted of course.
Any ideas on how to proceed?

Sub DavidHarris1987()
Dim wbk As Workbook
Dim wbk2 As Workbook
Dim i As Integer

strFirstFile = "C:\Excel\Workbook1.xlsx"
strSecondFile = "C:\Excel\Workbook2.xlsx"

Set wbk = Workbooks.Open(strFirstFile)
Set wbk = Workbooks.Open(strSecondFile)

With wbk.Sheets("Master Sheet")
For i = 1 To ActiveSheet.UsedRange.Columns.Count
If Range("A" & i) Like "*Total*" Then
Columns(i).Copy
wbk2.Sheets("Sheet1").Cells(1, wbk2.Sheets("Sheet1").UsedRange.Columns.Count + 1).PasteSpecial xlPasteAll
End If
Next i
End With

End Sub

Cheers,

Dave

[JOHN H. DAVIS]

Maybe:

Please Login or Register  to view this content.