Solved: paste to non contiguous named range

[ndendrinos]

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]

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:
[vba]
range("x1:X131") = range("A1:A131").values
[/vba]

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

[ndendrinos]

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]

Is there a rule of assignment for the cells?

[ndendrinos]

sorry not familiar with this phrase ... pls explain

[kroz]

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]

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]

Here is a sample file...

[kroz]

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

[vba]
for i = 1 to 131
Range(MyArray(i)).value = cells(1,i).value
next
[/vba]

[kroz]

I forgot this part on declaring the array:

[vba]
MyArray = Array("A24", "B23", ...)
[/vba]

[Kenneth Hobs]

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.
[vba]
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[/vba]

[ndendrinos]

just woke up. Well array looks better than what I have.
Thanks for your help kroz and have a good day

[ndendrinos]

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