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.
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
Is there a rule of assignment for the cells?
ndendrinos
12-15-2010, 04:07 AM
sorry not familiar with this phrase ... pls explain
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...
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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.