Hi Howard,

Am Mon, 17 Mar 2014 10:07:46 -0700 (PDT) schrieb L. Howard:

I'll study the old code and new to see if I can gather some insight on how you did that. Most of it remains over my head, but I pick up a little bit from time to time.

this code only reads cells with values into the array instead of 6
items.
And so the range is resized with Ubound(arrOut) +1 you get no empty
cells.


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

this code only reads cells with values into the array instead of 6

items.

And so the range is resized with Ubound(arrOut) +1 you get no empty

cells.





Regards

Claus B.

--

So I'm thinking that is done here where the space " " is replaced with nothing "" and if still greater than 0 it means there is text so it reads it into the array.

If Len(Replace(Tlt.Offset(0, i), " ", "")) 0 Then
ReDim Preserve arrOut(j)
arrOut(j) = Tlt.Offset(0, i)
j = j + 1
End If

Hi Howard,

Am Mon, 17 Mar 2014 15:20:17 -0700 (PDT) schrieb L. Howard:

So I'm thinking that is done here where the space " " is replaced with nothing "" and if still greater than 0 it means there is text so it reads it into the array.

If Len(Replace(Tlt.Offset(0, i), " ", "")) 0 Then
ReDim Preserve arrOut(j)
arrOut(j) = Tlt.Offset(0, i)
j = j + 1
End If

yes, that is the only change I made


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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.

The code errors out on this line where I have put "c" and c in place of "what goes here??"

Set wksTarget = wkbTarget.Sheets("What goes here??")
Set wksTarget = wkbTarget.Sheets("c")
Set wksTarget = wkbTarget.Sheets(c)

None work.

The Msgboxes both return a correct sheet name and a column number.
Which is Allee & 1 as they are the first entries of the list.

Thanks,
Howard


Sub Transfer_Titles()
Dim myRng As Range
Dim rngC As Range
Dim i As Long
Dim myArr() As Variant

Dim wksSource As Worksheet, wksTarget As Worksheet
Dim wkbSource As Workbook, wkbTarget As Workbook
Dim rngSource As Range, rngTarget As Range

Dim c As Range
Dim trgWs As Range
Dim trgCol As Long

Set myRng = Range("A2:A12100")

For Each rngC In myRng
ReDim Preserve myArr(myRng.Cells.Count - 1)
myArr(i) = rngC
i = i + 1
Next

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

Set wkbSource = Workbooks("Title Builder Randomizer rev 2.0 xfer titles.xlsm")
Set wkbTarget = Workbooks("Y.xlsm")

For Each c In Range("AU2:AU21")
MsgBox c
trgCol = c.Offset(0, 1)
MsgBox trgCol

Set wksTarget = wkbTarget.Sheets("What goes here??")

With wksSource
wksTarget.Cells(2, trgCol).Resize(rowsize:=myRng.Cells.Count) _
= WorksheetFunction.Transpose(myArr)
End With
Next 'c
End Sub

Also, I added this in case the workbook Y was not open.

If Not IsFileOpen("C:\Users\Howard Kittle\Documents\Y.xlsm") Then
Workbooks.Open ("C:\Users\Howard Kittle\Documents\Y.xlsm")
End If

It does indeed open the workbook if not open and the code runs on down until it errors out as I posted above.

However, the Msgboxes both return blank until the code is run again, then correct data is indicated. (of course it still errors out on that same line)

I don't understand why it prevents the variables from returning in the msgboxes on the opening run.

Howard

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

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