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

[tigerstewx]

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!

 

[bbotzong]

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]

Try:

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]

Try:

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]

Try:

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]

Thanks mumps - that worked brilliantly! Appreciate your help!

 

[mumps]

You are very welcome.