Hi Howard,

Am Tue, 18 Mar 2014 14:41:45 -0700 (PDT) schrieb L. Howard:

I need another nudge.
Want to transfer data workbook Y.
A list of target worksheets in book Y is in column AU of the source workbook/worksheet.
The target column for each target sheet is next to it in column AV.

Then try:

Sub Transfer_Titles()

Dim Dest As Range
Dim i As Long
Dim myArr() As Variant
Dim arrDest As Variant
Dim LRow As Long
Dim wkbSource As Workbook, wkbTarget As Workbook

LRow = Cells(Rows.Count, 1).End(xlUp).Row

myArr = Range("A2:A" & LRow)

'/ List of target sheet names in column AU2:AU21
'/ Destination column for each target sheet is in AV next to sheet name

Set wkbSource = ThisWorkbook
Set wkbTarget = Workbooks("Y.xlsm")

arrDest = Range("AU2:AV21")
For i = LBound(arrDest) To UBound(arrDest)
Set Dest = wkbTarget.Sheets(arrDest(i, 1)).Cells(2, arrDest(i, 2))
Dest.Resize(rowsize:=UBound(myArr)) = myArr
Dest.EntireColumn.AutoFit
Next 'i
End Sub


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

Hi Howard,

Am Wed, 19 Mar 2014 09:11:24 +0100 schrieb Claus Busch:

Enter a code line with

With ThisWorkbook.Sheets("Title Builder")

in case the sheet "Title Builder" is not the active sheet
Then don't forget the dots in front of the ranges

LRow = Cells(Rows.Count, 1).End(xlUp).Row

if all sections in all colors are filled you have more than 12100 rows,
otherwise you can have less.


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

On Wednesday, March 19, 2014 1:22:46 AM UTC-7, Claus Busch wrote:
Hi Howard,



Am Wed, 19 Mar 2014 09:11:24 +0100 schrieb Claus Busch:



Enter a code line with



With ThisWorkbook.Sheets("Title Builder")



in case the sheet "Title Builder" is not the active sheet

Then don't forget the dots in front of the ranges



LRow = Cells(Rows.Count, 1).End(xlUp).Row



if all sections in all colors are filled you have more than 12100 rows,

otherwise you can have less.





Regards

Claus B.

--

Vista Ultimate SP2 / Windows7 SP1

Office 2007 Ultimate SP3 / 2010 Prodessional


Hi Claus,

On a different sheet in the same project, I am trying to output column AQ to both column A and sheet 2 column B of the same workbook. This sheet is very almost identical to the Titles sheet except here it is returning up to six short phrases to the taget cells.

This is one of many attempts to get it to write to sheet2.
Is this a case like you describe above.

Writes to sheet 1 just fine, the active sheet.

Sub A2_Down_Copy()
Dim lRowCount
lRowCount = Cells(Rows.Count, "AE").End(xlUp).Row

With Sheets("Sheet1").Range("A2").Resize(lRowCount)
.Formula = "=CONCATENATE(AE2&AG2&AI2&AK2&AM2&AO2)": .Value = .Value
End With

With Sheets("Sheet2").Range("B2").Resize(lRowCount)
.Formula = "=CONCATENATE(AE2&AG2&AI2&AK2&AM2&AO2)": .Value = .Value
End With

End Sub

Thanks.
Howard

Hi Howard,

Am Wed, 19 Mar 2014 15:52:12 -0700 (PDT) schrieb L. Howard:

This is one of many attempts to get it to write to sheet2.
Is this a case like you describe above.

I would do it with the formula only once.
Try:

Sub A2_Down_Copy()
Dim lRowCount
Dim myArr As Variant

With Sheets("Sheet1")
lRowCount = .Cells(Rows.Count, "AE").End(xlUp).Row
With .Range("A2").Resize(lRowCount)
.Formula = "=CONCATENATE(AE2&AG2&AI2&AK2&AM2&AO2)"
.Value = .Value
myArr = Range("A2:A" & lRowCount)
End With
End With

Sheets("Sheet2").Range("B2").Resize(lRowCount) = myArr

End Sub


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

On Wednesday, March 19, 2014 11:37:20 PM UTC-7, Claus Busch wrote:
Hi Howard,



Am Wed, 19 Mar 2014 15:52:12 -0700 (PDT) schrieb L. Howard:



This is one of many attempts to get it to write to sheet2.

Is this a case like you describe above.



I would do it with the formula only once.

Try:



Sub A2_Down_Copy()

Dim lRowCount

Dim myArr As Variant



With Sheets("Sheet1")

lRowCount = .Cells(Rows.Count, "AE").End(xlUp).Row

With .Range("A2").Resize(lRowCount)

.Formula = "=CONCATENATE(AE2&AG2&AI2&AK2&AM2&AO2)"

.Value = .Value

myArr = Range("A2:A" & lRowCount)

End With

End With



Sheets("Sheet2").Range("B2").Resize(lRowCount) = myArr



End Sub





Regards

Claus B.

--

Thanks Claus. That works well for me. Sheet 1 copy is perfect.

The Sheet 2 copy was producing a ghost #N/A in row 2002. I did this and it went away.

Sheets("Sheet2").Range("B2").Resize(lRowCount - 1) = myArr

Row 2 and 2001 on both sheets are identical each time I test.

I did notice that Column AE2 is blank and the blank repeats every 20 rows. Does not affect the copy that your code does. All the blank rows are copied as 5 short phrases instead of 6. More troubleshooting to do.

But like your code, always top notch.

Thanks again.

Howard

Hi Howard,

Am Thu, 20 Mar 2014 06:14:42 -0700 (PDT) schrieb L. Howard:

Sheets("Sheet2").Range("B2").Resize(lRowCount - 1) = myArr

that is my bad

I did notice that Column AE2 is blank and the blank repeats every 20 rows. Does not affect the copy that your code does. All the blank rows are copied as 5 short phrases instead of 6. More troubleshooting to do.

do you want to skip blank cells?
Can you send me the workbook?


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

Hi Howard,

Am Thu, 20 Mar 2014 06:14:42 -0700 (PDT) schrieb L. Howard:

I did notice that Column AE2 is blank and the blank repeats every 20 rows. Does not affect the copy that your code does. All the blank rows are copied as 5 short phrases instead of 6. More troubleshooting to do.

is following code that what you want?

Sub CopyToA2()
Dim i As Long, j As Long
Dim myStr As String
Dim myArr As Variant

Application.ScreenUpdating = False
For i = 2 To 2001
myStr = ""
For j = 31 To 41 Step 2
If Len(Replace(Cells(i, j), " ", "")) 0 Then
myStr = myStr & Cells(i, j)
End If
Next
Cells(i, 1) = myStr
Next
myArr = Range("A2:A2001")
Sheets("Sheet2").Range("A2").Resize(rowsize:=UBoun d(myArr)) = myArr
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

Hi Howard,

Am Thu, 20 Mar 2014 15:00:24 +0100 schrieb Claus Busch:

is following code that what you want?

if the result is what you want try following code. It is a bit faster.
If not please send me the workbook with the expected result.

Sub CopyToA2_2()
Dim i As Long, j As Long
Dim myStr As String
Dim myArr As Variant

Application.ScreenUpdating = False
myArr = Range("AE2:AO2001")
For i = LBound(myArr) To UBound(myArr)
myStr = ""
For j = 1 To 11 Step 2
If Len(Replace(myArr(i, j), " ", "")) 0 Then
myStr = myStr & myArr(i, j)
End If
Next
Cells(i + 1, 1) = myStr
Next
myArr = Range("A2:A2001")
Sheets("Sheet2").Range("A2").Resize(rowsize:=UBoun d(myArr)) = myArr
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Vista Ultimate SP2 / Windows7 SP1
Office 2007 Ultimate SP3 / 2010 Prodessional

The target column for each target sheet is next to it in column AV.



Then try:



Sub Transfer_Titles()



Dim Dest As Range

Dim i As Long

Dim myArr() As Variant

Dim arrDest As Variant

Dim LRow As Long

Dim wkbSource As Workbook, wkbTarget As Workbook



LRow = Cells(Rows.Count, 1).End(xlUp).Row



myArr = Range("A2:A" & LRow)



'/ List of target sheet names in column AU2:AU21

'/ Destination column for each target sheet is in AV next to sheet name



Set wkbSource = ThisWorkbook

Set wkbTarget = Workbooks("Y.xlsm")



arrDest = Range("AU2:AV21")

For i = LBound(arrDest) To UBound(arrDest)

Set Dest = wkbTarget.Sheets(arrDest(i, 1)).Cells(2, arrDest(i, 2))

Dest.Resize(rowsize:=UBound(myArr)) = myArr

Dest.EntireColumn.AutoFit

Next 'i

End Sub





Regards

Claus B.



Oh yes! That works very quick. Nice. About 0.623 seconds to transfer 10,000 rows to twenty sheets.

I wrote a couple of lines to recalc the data between each sheet transfer so that each sheet got a unique set of data and the time was 36 seconds. That seems quite reasonable to me given it is the recalc that takes the time, not the transfer.

Thanks Claus. The array speed is always impressive.

Howard