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

  • Thread starter Thread starter farid2001
  • Start date Start date
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
 
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
 
Thank you for your fast response.
I get error9 message, "Sub Index out of....
What could be wrong?
 
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
 
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...
 
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...
 
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...
 
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...
 
Back
Top