Excel VBA Macro to copy and paste data from one sheet and paste into different sheets based on cell values on first sheet

tigerstewx

New Member
Joined
Jun 28, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I was trying to put together a macro to copy certain cell values on "Sheet 1" to different sheets in the same workbook based on the cell values in column B.

Basically, column B allows the user to enter the name of the worksheet to which the data should be pasted. I then want to copy the data in that same row in column D and columns E:S and paste it in the relevant worksheet based on the cell value in column B.

When pasting the data, I want the macro to find the next blank row before pasting. The data in column D from Sheet 1 should be pasted in Column B in the destination sheet and columns E:S should be pasted in Columns E:S in the destination as well.

I want the macro to keep looping through all the rows in Sheet 1 until there is a blank cell in column B and therefore no more data to copy and paste. The first cell with data is B5 on Sheet 1.

Please let me know if that isn't clear. Thank you all so much! I have been struggling with this for quite some time now.

Thanks again!
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

bbotzong

Board Regular
Joined
Dec 17, 2003
Messages
56
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
  5. 2010
Platform
  1. Windows
I think your logic should look like this:

1. Use a variable to keep the row number on your source sheet.
2. Get destination sheet name from column B from that row
3. Find the last row in the destination sheet by either using a loop counter, or using something like Selection.SpecialCells(xlCellTypeLastCell).Select
4. Select and move the data from source sheet to destination sheet.
5. Increment your counter and repeat using a DO...LOOP until the cell in the row you're on is blank.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,408
Try:
VBA Code:
Sub copydata()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, ws As Range
    Set srcWS = Sheets("Sheet1")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each ws In srcWS.Range("B5:B" & LastRow)
        With Sheets(ws.Value)
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = ws.Offset(, 2)
            .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Resize(, 15).Value = ws.Offset(, 3).Resize(, 15).Value
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub
 

tigerstewx

New Member
Joined
Jun 28, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Try:
VBA Code:
Sub copydata()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, ws As Range
    Set srcWS = Sheets("Sheet1")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each ws In srcWS.Range("B5:B" & LastRow)
        With Sheets(ws.Value)
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = ws.Offset(, 2)
            .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Resize(, 15).Value = ws.Offset(, 3).Resize(, 15).Value
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub

Thanks for your help. I tried the code but got a run-time error 9: Subscript out of range. I have some information in column A of Sheet 1 which I want the macro to ignore. I want to set the last row only from Column B. Is that the reason for the runtime error?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,408

ADVERTISEMENT

Try:
VBA Code:
Sub copydata()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, ws As Range
    Set srcWS = Sheets("Sheet1")
    LastRow = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
    For Each ws In srcWS.Range("B5:B" & LastRow)
        With Sheets(ws.Value)
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = ws.Offset(, 2)
            .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Resize(, 15).Value = ws.Offset(, 3).Resize(, 15).Value
        End With
    Next ws
    Application.ScreenUpdating = True
End Sub
 

tigerstewx

New Member
Joined
Jun 28, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Thanks mumps - that worked brilliantly! Appreciate your help!
 

Watch MrExcel Video

Forum statistics

Threads
1,132,912
Messages
5,655,912
Members
418,250
Latest member
Jebacmakro

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