PDA

View Full Version : Solved: paste to non contiguous named range



ndendrinos
12-14-2010, 08:13 PM
On sheet1 Row1 (range A1:EA1) I have data. Sometimes all 131 cells have a value, sometimes some are empty.

I have named 131 cells chosen on the same worksheet “test”
These cells are non contiguous.

What code could copy the data from the Row1 and paste same in the 131 non contiguous cells (from what I understand looping one by one) ?

Thank you.

kroz
12-15-2010, 12:47 AM
i'm a bit confused here.. so do you want to just paste these cells from one place to the other in the same worksheet ?
You lost me at the "I have named 131 cells chosen on the same worksheet “test”"

Anyway, to copy a range you can use:

range("x1:X131") = range("A1:A131").values


Do you want to copy only the non blank cells ? If so then the code would change :)

ndendrinos
12-15-2010, 03:56 AM
Hello kroz and sorry for the confusion.
Ideally the code should be as short as:

range("test") = range("A1:A131").values

Right now I could make it work like this: (this is abbreviated)

Sub test()

[A24] = [A1]
[B23] = [B1]
[A16] = [C1]
[D20] = [D1]
[E12] = [E1]
[F27] = [F1]
[E16] = [G1]
[A15] = [H1]
[K14] = [I1]
[L20] = [J1]
[P21] = [K1]
[M19] = [L1]
' on & on & on 131 times....
End Sub

kroz
12-15-2010, 04:04 AM
Is there a rule of assignment for the cells?

ndendrinos
12-15-2010, 04:07 AM
sorry not familiar with this phrase ... pls explain

kroz
12-15-2010, 04:14 AM
to be able to copy - paste the cells you have to tell excel to take x cell to y cell following a rule.
Let's say you want to copy a range of 10 cells from row 1(columns A to J) to a different location. You need to have in your mind a way of linking the cells.
The numbers A24, B23, A16, D20 don't really have a link between them while A24, B23, C22, D21 do.

ndendrinos
12-15-2010, 04:34 AM
I think I understand what you mean now.
The range named:"test" is non contiguous that is why I think the code will have to loop and do the pasting one by one.
Here is what I have and it works (but there should be a better way)


Private Function My_Workbook_Open(sFilePath As String) As Workbook
'//Opens a workbook and returns a reference to it
'//Returns Nothing if no workbook of the name exists
On Error Resume Next
Set My_Workbook_Open = Workbooks.Open(sFilePath)
End Function


Sub search()
Application.ScreenUpdating = False

Dim FN As String
FN = Range("B2").Value
Dim FR As String
FR = Range("D2")
'To open
Workbooks.Open (ThisWorkbook.Path & "\depot\" & FN)
Dim c As Range
lookfor = FR

With Sheets("sheet1")
Set c = .Columns(1).Find(What:=lookfor, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
If Not c Is Nothing Then
c.EntireRow.Copy


Workbooks("hello toronto").Activate
Workbooks("hello toronto").Sheets("Search").Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False

Call test

Else

Workbooks("hello toronto").Activate
MsgBox lookfor & " not found"


End If
End With
Application.ScreenUpdating = True

End Sub


Sub test()

[A24] = [A1]
[B23] = [B1]
[A16] = [C1]
[D20] = [D1]
[E12] = [E1]
[F27] = [F1]
[E16] = [G1]
[A15] = [H1]
[K14] = [I1]
[L20] = [J1]
[P21] = [K1]
[M19] = [L1]

End Sub

Pls note that the sub "test" is incomplete here ... in fact it should be 131 lines long.

ALSO: I have the silly habit of naming all temporary codes AND named ranges "test"
In the file i'm wresling with the named ranged of the non contiguous cells is: test
as well the name of teh sub is also test.

What the code does:
On sheet "shearch" in WB "hello toronto" in cells:
B2 I type the name of a Company
D2 I type an Invoice number

The code looks for a file matching the name in B2 within a folder called "depot"
Then it opens the file and matches value D2 to column A of sheet1 of that file/ copies the whole row(131 cells, with empties or without) comes back to sheet "search" and paste the data in row1

The code that I'm trying to simplify will place each value from Row1 to selected cells (the cells are non contiguous)

Hope I don't confuse you more ... I could attach the whole thing if you want

ndendrinos
12-15-2010, 05:52 AM
Here is a sample file...

kroz
12-15-2010, 06:21 AM
Well..the only idea i could come up with is this:
create an array with all the cells in Test (cells in the left side) and assign them like so


for i = 1 to 131
Range(MyArray(i)).value = cells(1,i).value
next

kroz
12-15-2010, 06:53 AM
I forgot this part on declaring the array:


MyArray = Array("A24", "B23", ...)

Kenneth Hobs
12-15-2010, 08:01 AM
You should note that your mylist range started at M26.

Here is my approach. It could fail if you have more values in row 1 than in the mylist range. This could be addressed though.

Sub t()
Dim r As Range, topRange As Range, i As Integer, a() As Variant
ReDim a(1 To Range("mylist").Count) As Variant
i = 0
For Each r In Range("mylist")
i = i + 1
a(i) = r.Address
Next r
Set topRange = Range("A1", Cells(1, Columns.Count).End(xlToLeft))
i = 0
For Each r In topRange
i = i + 1
Range(a(i)).Value = r.Value
Next r
End Sub

ndendrinos
12-15-2010, 08:02 AM
just woke up. Well array looks better than what I have.
Thanks for your help kroz and have a good day

ndendrinos
12-15-2010, 08:21 AM
Sorry Kenneth Hobs as I said just woke up or maybe you were posting as I was.
I think this is what I've been looking for as per my initial question.
I'll work on it later on today .Many thanks

One last thing:
The Invoicing system I'm setting up is a two way system between a template invoice and a folder where the records of the invoices are kept.
The procedure is like this:
To save an invoice I use this code (maybe it will make things more clear as my post here tries to do the reverse ... that is to rebuild an invoice through "Search" by importing the pertinent row from the customer's folder in Row1 of the "search"

I hope I'm not making things more complicated and I'm just posting this just in case there is an even better way than already suggested and that would be to skip the import of the row and do the copy paste directly.

Here is the code and I'm off for breakfast:


Sub saveinvoice()
Application.ScreenUpdating = False
Dim rngCell As Range
Dim lngCount As Long
Dim aTemp()

ReDim aTemp(0)
lngCount = 0

For Each rngCell In [alpha]
aTemp(UBound(aTemp)) = rngCell
ReDim Preserve aTemp(UBound(aTemp) + 1)
Next rngCell

ReDim Preserve aTemp(UBound(aTemp) - 1)

Set wb = My_Workbook_Open((ThisWorkbook.Path & "\RECORDS\" & FN) & Range("B8").Value)

'//Paste something into it
If Not wb Is Nothing Then
With wb.Worksheets(1)
Destination = Range("A" & Rows.Count).End(xlUp).Offset(1)

For Each rngCell In [beta]



rngCell = aTemp(lngCount)
lngCount = lngCount + 1
Next rngCell
End With

'//Cosmetic
Rows("1:1").Select
Columns("B:B").ColumnWidth = 13.14
Columns("E:E").ColumnWidth = 33.29
Columns("I:I").ColumnWidth = 11.29
Columns("H:H").ColumnWidth = 22.43
Columns("F:F").ColumnWidth = 17.14
Columns("I:I").ColumnWidth = 13.86
Columns("K:K").ColumnWidth = 12.29

Selection.Insert Shift:=xlDown
Else
'//the workbook didn't exist. Create a new one.
Set NewBook = Workbooks.Add



'//Do stuff with new workbook
Sheets("Sheet1").Names.Add Name:="beta", RefersTo:="=Sheet1!A1:EA1"

For Each rngCell In [beta]
rngCell = aTemp(lngCount)
lngCount = lngCount + 1
Next rngCell


ActiveWorkbook.SaveAs Filename:=(ThisWorkbook.Path & "\RECORDS\" & FN & Workbooks("Invoicer").Worksheets("Invoice").Range("B8").Value)
Rows("1:1").Select
Selection.Insert Shift:=xlDown

End If
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "Data saved"
Application.ScreenUpdating = True
End Sub

'-----------------------------------------------------------------
Private Function My_Workbook_Open(sFilePath As String) As Workbook
'//Opens a workbook and returns a reference to it
'//Returns Nothing if no workbook of the name exists
On Error Resume Next
Set My_Workbook_Open = Workbooks.Open(sFilePath)

End Function