Step through range x, copy and paste columns in range y based on values in range x

mac8832

New Member
Joined
Jul 13, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Thank you in advance for your consideration and help. I am new to the message board and hope I find a VBA solution to the following:

I want to step through values within range x in worksheet1 to the extent the range contains numerical values (end loop after last row of data is passed). When within the loop, I want to lookup range y in worksheet2 based on the cell value in range x, then copy and paste range y to worksheet3. When pasting range y to worksheet3, I do not want to overwrite existing data, but paste to the right of the last column with data. For each value in range x in worksheet1, there are three columns in worksheet2 to copy and paste to worksheet3 (i.e, 3 in range x corresponds to 3x 3's in range y).

range x in worksheet1:
1626202711402.png



range y in worksheet2:
1626202776732.png


copy/paste to worksheet3:

1626203094869.png

The left border on column D indicates where the first column of data is pasted. As I had mentioned above, 3 columns in range y will be pasted per 1 value in range x. Once pasted, the next 3 columns in range y corresponding to the next value in range x will be pasted to the next three columns to the right.

Thank you again.
 

Attachments

  • 1626202992363.png
    1626202992363.png
    1.7 KB · Views: 7

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel

Assuming the data on sheet1 starts in cell A2.
Assuming the data on sheet2 starts in cell A1.

Try this

VBA Code:
Sub copycolumns()
  Dim i As Long, lr As Long
  Dim c As Range, f As Range, r As Range
  
  With Sheets("Sheet2")
    lr = .Range("A" & Rows.Count).End(3).Row
    For Each c In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(3))
      Set f = .Rows(1).Find(c.Value, , xlValues, xlWhole)
      If Not f Is Nothing Then
        If r Is Nothing Then Set r = f.Resize(lr, 3) Else Set r = Union(r, f.Resize(lr, 3))
      End If
    Next
  End With
  r.Copy Sheets("Sheet3").Range("D2")
End Sub

________________________________________
Note:
In the following threads that you create, you can Use Xl2BB tool minisheets to show examples.
________________________________________
 

mac8832

New Member
Joined
Jul 13, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
DanteAmor,

Thank you. It worked very well :).

Taking this a step further, how would I expand on the above code to include the following:

I am inclined to think that this would fit in after End With. Once the 'with loop' ends and range r is copied to worksheet3, how would I paste range r into a user-defined worksheet?

All other things the same,

1626976292296.png

The cell in worksheet1 containing "Sheet 4" indicates that range r will be pasted to worksheet4. However, the user may change this cell to indicate another worksheet to paste range r:

1626976432101.png

Here, range r is pasted to worksheet3.

1626976543923.png


I am attempting to place an If/Else loop and lookup function after End With, but am so far unsuccessful in pasting range r to any worksheet (worksheets 4 - 7) beyond.

Thank you, again, for taking a look at this and coming to an elegant solution to my previous post.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
Change this line:
VBA Code:
  r.Copy Sheets("Sheet3").Range("D2")

For this line:
VBA Code:
  r.Copy Sheets(Sheets("Sheet1").Range("E2").Value).Range("D2")

In cell E2 of sheet1 you must put the name of the destination sheet.
 

mac8832

New Member
Joined
Jul 13, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I was able to make it work with a big block of If/ElseIf statements. I deleted that block, inserted what you've shown above, and it works perfectly. Thank you.

Now, what code would I need to ensure that once I have pasted range r to the destination sheet and save and close the workbook, the next time I open the workbook and paste range r to the same destination sheet, I do not overwrite range r data that is already in that destination sheet (or, any destination sheet already containing range r data). I notice that when I change the values of range x in worksheet1, I overwrite range r data that already exists in the destination sheet.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
Change to this:
VBA Code:
r.Copy Sheets(Sheets("Sheet1").Range("E2").Value).Range("D" & Rows.Count).End(3)(2)
 

mac8832

New Member
Joined
Jul 13, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

DanteAmor, this worked well in appending data vertically without overwriting existing data. Is there a way I can append columns to the right of the existing data?

I appreciate all your help here.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
@mac8832 You marked one of your answers as a solution, you must mark as a solution one of the answers that really solved your request.
 

mac8832

New Member
Joined
Jul 13, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Understood, thanks for the guidance. I unmarked the request as I just sent an additional request (#7).
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,922
Office Version
  1. 2007
Platform
  1. Windows
Try this

VBA Code:
Sub copycolumns()
  Dim i As Long, lr As Long, lc As Long
  Dim c As Range, f As Range, r As Range
  Dim sName As String
  
  With Sheets("Sheet2")
    lr = .Range("A" & Rows.Count).End(3).Row
    For Each c In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(3))
      Set f = .Rows(1).Find(c.Value, , xlValues, xlWhole)
      If Not f Is Nothing Then
        If r Is Nothing Then Set r = f.Resize(lr, 3) Else Set r = Union(r, f.Resize(lr, 3))
      End If
    Next
  End With
  sName = Sheets("Sheet1").Range("E2").Value
  lc = Sheets(sName).Cells(2, Columns.Count).End(1).Column + 1
  lc = WorksheetFunction.Max(4, lc)
  r.Copy Sheets(sName).Cells(2, lc)
End Sub
 
Solution

Forum statistics

Threads
1,147,734
Messages
5,742,863
Members
423,760
Latest member
photogfrog

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top