VBA to Copy range from Sheet to another and defined a name

[Persl]

Good day all


I need a vba code to do the following comands:

1 - copy range ("GT300") and ("GV300", Selection.End(xlToRight)) from ("Sheet1")
2 - H lookup ("Sheet1") ("GT291") on ("Sheet2").Range("B:B")
3 - Add the copied ranges from ("Sheet1") as new entery on ("Sheet2") based on the H lookup result
4 - Create new defined name from ("Sheet2") last entery from column D to last value on same row , Selection.CreateNames Top:=False, Left:=True, Bottom:=False, Right:=False

Add test.xlsx

[HansV]

Welcome to Eileen's Lounge!

Here you go:

Code: Select all

Sub RectangleRoundedCorners3_Click()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim firstcell As Range
    Dim lastcell As Range
    Dim newcell As Range
    Dim destcell As Range
    Application.ScreenUpdating = False
    Set ws1 = Worksheets("Sheet1")
    Set firstcell = ws1.Range("GV300")
    Set lastcell = ws1.Cells(300, ws1.Columns.Count).End(xlToLeft)
    Set ws2 = Worksheets("Sheet2")
    Set newcell = ws2.Range("B:B").Find(What:=ws1.Range("GT291").Value, LookAt:=xlWhole)
    If newcell Is Nothing Then
        Beep
        Exit Sub
    Else
        Set destcell = newcell.Offset(9).End(xlUp).Offset(1)
        destcell.Value = ws1.Range("GT300").Value
        With destcell.Offset(0, 2).Resize(1, lastcell.Column - firstcell.Column + 1)
            .Value = ws1.Range(firstcell, lastcell).Value
            .CreateNames Top:=False, Left:=True, Bottom:=False, Right:=False
        End With
    End If
    Application.ScreenUpdating = True
End Sub

[Persl]

Hi Hans

The code work perfectly.

Another question if you could get me

What should I do If I need to edit the previous entry on Sheet2

[HansV]

What do you want to use as identifier? The value in GT300 (Q WWW P)?

[HansV]

If you do want to use GT300 as identifier:

Code: Select all

Sub RectangleRoundedCorners3_Click()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim firstcell As Range
    Dim lastcell As Range
    Dim newcell As Range
    Dim destcell As Range
    Application.ScreenUpdating = False
    Set ws1 = Worksheets("Sheet1")
    Set firstcell = ws1.Range("GV300")
    Set lastcell = ws1.Cells(300, ws1.Columns.Count).End(xlToLeft)
    Set ws2 = Worksheets("Sheet2")
    Set newcell = ws2.Range("B:B").Find(What:=ws1.Range("GT291").Value, LookAt:=xlWhole)
    If newcell Is Nothing Then
        Beep
        Exit Sub
    Else
        Set destcell = newcell.Offset(1).Resize(8).Find(What:=ws1.Range("GT300").Value, LookAt:=xlWhole)
        If destcell Is Nothing Then
            Set destcell = newcell.Offset(9).End(xlUp).Offset(1)
            destcell.Value = ws1.Range("GT300").Value
        End If
        With destcell.Offset(0, 2).Resize(1, lastcell.Column - firstcell.Column + 1)
            .Value = ws1.Range(firstcell, lastcell).Value
            .CreateNames Top:=False, Left:=True, Bottom:=False, Right:=False
        End With
    End If
    Application.ScreenUpdating = True
End Sub

[Persl]

Until here all is perfect,

Now I need to browse the Sheet2 entry and update the data for each row separately if needed.

[HansV]

Where do we get the data to be updated from?

[Persl]

In sheet1 each time we add new data, that data will sort on sheet2 base on that category, so we could need to extract one row and edit it then update the sheet2

[HansV]

That is what the code I posted previously does...