Copy Column D from all worksheets in WB1 and paste in sheet1 WB2

F

farid2001

Hello
I need help with code.
I have Workbook A with 70+ worksheets, and I want to copy contents from
column D from each worksheet and paste in Workbook B Sheet1 so that it looks
like:

Column C Column D Column E Column F
Col D sht1 Col D sht2 Col D sht3 Col D sht4

and so on.
Is this possible?
Please help me.
Thanks & regards
farid2001
 
P

Per Jessen

Hi

I think this should do it:

Sub CopyCols()
Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long

Set wbA = ThisWorkbook
Set wbB = Workbooks("Book2") ' Change to suit
Set DestSh = wbB.Worksheets("Sheet1")

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
wbA.Worksheets(sh.Name).Columns("D").Copy Destination:=DestSh.Range
("C1").Offset(0, off)
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per
 
F

farid2001

Thank you for your fast response.
I get error9 message, "Sub Index out of....
What could be wrong?
 
F

farid2001

Per
Thanks a million, it worked perfectly, I forgot to write .xslx

Regards
farid2001
 
F

farid2001

Per
Not all worksheets in wbA column D have the same # of rows
Column B has customer ID and column D has dollars used.
wbB has in Range A2:A201 the ID's of the 200 customers I have.
Range B2:B201 customer name
therefore the formula I use to determine who spent dollars is:
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('[Child June
2008.xlsx]01-06'!R4C4:R136C4,MATCH(RC[-2],'[Child June
2008.xlsx]01-06'!R4C2:R136C2,0)),0)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C201")
Range("C2:C201").Select
What should the code be instead of Copy Destination?

Thank you very much for your help.
Regards
Farid
 
P

Per Jessen

Hi

Try this (not tested)

Sub CopyCols()
Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long
Dim r As Long
Dim LastRow As Long
Dim TargetRow As Long

Set wbA = ThisWorkbook
Set wbB = Workbooks("Book2") ' Change to suit
Set DestSh = wbB.Worksheets("Sheet1")

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
If wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row = 201 Then
wbA.Worksheets(sh.Name).Columns("D").Copy _
Destination:=DestSh.Range("C1").Offset(0, off)
Else
LastRow = wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row
For r = 2 To LastRow
TargetRow = Application.WorksheetFunction.Match(wbA.Worksheets _
(sh.Name).Cells(r, 2).Value, DestSh.Range("A2:A201"), 1)
wbA.Worksheets(sh.Name).Cells(r, 4).Copy _
Destination:=DestSh.Cells(TargetRow, 3 + off)
Next
End If
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per

farid2001 said:
Per
Not all worksheets in wbA column D have the same # of rows
Column B has customer ID and column D has dollars used.
wbB has in Range A2:A201 the ID's of the 200 customers I have.
Range B2:B201 customer name
therefore the formula I use to determine who spent dollars is:
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('[Child June
2008.xlsx]01-06'!R4C4:R136C4,MATCH(RC[-2],'[Child June
2008.xlsx]01-06'!R4C2:R136C2,0)),0)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C201")
Range("C2:C201").Select
What should the code be instead of Copy Destination?

Thank you very much for your help.
Regards
Farid

Per Jessen said:
Which line throws the the error?

Regards,
Per
Click to expand...
Click to expand...
 
F

farid2001

Per
Thanks for your help.
It does work but only does the first 2 worksheets, then I get error message
'1004'
"Error defined by object or application"

Regards
Farid

Per Jessen said:
Hi

Try this (not tested)

Sub CopyCols()
Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long
Dim r As Long
Dim LastRow As Long
Dim TargetRow As Long

Set wbA = ThisWorkbook
Set wbB = Workbooks("Book2") ' Change to suit
Set DestSh = wbB.Worksheets("Sheet1")

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
If wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row = 201 Then
wbA.Worksheets(sh.Name).Columns("D").Copy _
Destination:=DestSh.Range("C1").Offset(0, off)
Else
LastRow = wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row
For r = 2 To LastRow
TargetRow = Application.WorksheetFunction.Match(wbA.Worksheets _
(sh.Name).Cells(r, 2).Value, DestSh.Range("A2:A201"), 1)
wbA.Worksheets(sh.Name).Cells(r, 4).Copy _
Destination:=DestSh.Cells(TargetRow, 3 + off)
Next
End If
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per

farid2001 said:
Per
Not all worksheets in wbA column D have the same # of rows
Column B has customer ID and column D has dollars used.
wbB has in Range A2:A201 the ID's of the 200 customers I have.
Range B2:B201 customer name
therefore the formula I use to determine who spent dollars is:
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('[Child June
2008.xlsx]01-06'!R4C4:R136C4,MATCH(RC[-2],'[Child June
2008.xlsx]01-06'!R4C2:R136C2,0)),0)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C201")
Range("C2:C201").Select
What should the code be instead of Copy Destination?

Thank you very much for your help.
Regards
Farid

Per Jessen said:
Which line throws the the error?

Regards,
Per

On 13 Nov., 03:53, farid2001 <[email protected]>
wrote:
Thank you for your fast response.
I get error9 message, "Sub Index out of....
What could be wrong?
Click to expand...
Click to expand...
Click to expand...
 
P

Per Jessen

Farid,
Which line throws the error ?

Does the two first sheets have 200 lines.

If you want you can send me a sample workbook which I can use to test the
macro.

Regards,
Per

farid2001 said:
Per
Thanks for your help.
It does work but only does the first 2 worksheets, then I get error
message
'1004'
"Error defined by object or application"

Regards
Farid

Per Jessen said:
Hi

Try this (not tested)

Sub CopyCols()
Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long
Dim r As Long
Dim LastRow As Long
Dim TargetRow As Long

Set wbA = ThisWorkbook
Set wbB = Workbooks("Book2") ' Change to suit
Set DestSh = wbB.Worksheets("Sheet1")

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
If wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row = 201 Then
wbA.Worksheets(sh.Name).Columns("D").Copy _
Destination:=DestSh.Range("C1").Offset(0, off)
Else
LastRow = wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row
For r = 2 To LastRow
TargetRow =
Application.WorksheetFunction.Match(wbA.Worksheets _
(sh.Name).Cells(r, 2).Value, DestSh.Range("A2:A201"), 1)
wbA.Worksheets(sh.Name).Cells(r, 4).Copy _
Destination:=DestSh.Cells(TargetRow, 3 + off)
Next
End If
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per

farid2001 said:
Per
Not all worksheets in wbA column D have the same # of rows
Column B has customer ID and column D has dollars used.
wbB has in Range A2:A201 the ID's of the 200 customers I have.
Range B2:B201 customer name
therefore the formula I use to determine who spent dollars is:
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('[Child June
2008.xlsx]01-06'!R4C4:R136C4,MATCH(RC[-2],'[Child June
2008.xlsx]01-06'!R4C2:R136C2,0)),0)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C201")
Range("C2:C201").Select
What should the code be instead of Copy Destination?

Thank you very much for your help.
Regards
Farid

:

Which line throws the the error?

Regards,
Per

On 13 Nov., 03:53, farid2001 <[email protected]>
wrote:
Thank you for your fast response.
I get error9 message, "Sub Index out of....
What could be wrong?
Click to expand...
Click to expand...
Click to expand...
 
F

farid2001

Per

Awesome!!
Your code worked to perfection.

Sub CopyCalcCols()

Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long
Dim r As Long
Dim LastRow As Long
Dim TargetRow As Long
Set wbA = ThisWorkbook
Set wbB = Workbooks("Master.xlsx")
Set DestSh = wbB.Worksheets("Hoja1")
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
If wbA.Worksheets(sh.Name).Range("D4").End(xlDown).Row = 202 Then
wbA.Worksheets(sh.Name).Columns("D").Copy _
Destination:=DestSh.Range("C1").Offset(0, off)
Else
LastRow = wbA.Worksheets(sh.Name).Range("D4").End(xlDown).Row - 1
For r = 4 To LastRow
TargetRow = Application.WorksheetFunction.Match(wbA.Worksheets _
(sh.Name).Cells(r, 2).Value, DestSh.Range("A2:A201"), 1)
wbA.Worksheets(sh.Name).Cells(r, 4).Copy _
Destination:=DestSh.Cells(TargetRow + 1, 3 + off)
Next
End If
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Thanks & regards
Farid

Per Jessen said:
Farid,
Which line throws the error ?

Does the two first sheets have 200 lines.

If you want you can send me a sample workbook which I can use to test the
macro.

Regards,
Per

farid2001 said:
Per
Thanks for your help.
It does work but only does the first 2 worksheets, then I get error
message
'1004'
"Error defined by object or application"

Regards
Farid

Per Jessen said:
Hi

Try this (not tested)

Sub CopyCols()
Dim wbA As Workbook
Dim wbB As Workbook
Dim DestSh As Worksheet
Dim off As Long
Dim r As Long
Dim LastRow As Long
Dim TargetRow As Long

Set wbA = ThisWorkbook
Set wbB = Workbooks("Book2") ' Change to suit
Set DestSh = wbB.Worksheets("Sheet1")

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Sheets
If wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row = 201 Then
wbA.Worksheets(sh.Name).Columns("D").Copy _
Destination:=DestSh.Range("C1").Offset(0, off)
Else
LastRow = wbA.Worksheets(sh.Name).Range("D2").End(xlDown).Row
For r = 2 To LastRow
TargetRow =
Application.WorksheetFunction.Match(wbA.Worksheets _
(sh.Name).Cells(r, 2).Value, DestSh.Range("A2:A201"), 1)
wbA.Worksheets(sh.Name).Cells(r, 4).Copy _
Destination:=DestSh.Cells(TargetRow, 3 + off)
Next
End If
off = off + 1
Next
Application.ScreenUpdating = True
End Sub

Regards,
Per

"farid2001" <[email protected]> skrev i meddelelsen
Per
Not all worksheets in wbA column D have the same # of rows
Column B has customer ID and column D has dollars used.
wbB has in Range A2:A201 the ID's of the 200 customers I have.
Range B2:B201 customer name
therefore the formula I use to determine who spent dollars is:
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(INDEX('[Child June
2008.xlsx]01-06'!R4C4:R136C4,MATCH(RC[-2],'[Child June
2008.xlsx]01-06'!R4C2:R136C2,0)),0)"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C201")
Range("C2:C201").Select
What should the code be instead of Copy Destination?

Thank you very much for your help.
Regards
Farid

:

Which line throws the the error?

Regards,
Per

On 13 Nov., 03:53, farid2001 <[email protected]>
wrote:
Thank you for your fast response.
I get error9 message, "Sub Index out of....
What could be wrong?
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Select / Copy / Paste 6
check Wb is open and copy data to it 10
Intersect and Union 2
help with syntax for copy and pasting rows across sheets 4
comment copy 3
Retriving value from multiple sources 2
loop to copy paste 5
Copy rows from Sheet1 to Sheet2 when Column B values equal "X" andColumn C values > 100 2

Top