VBA to copy number of rows to specific sheets based on a few cell values

[stupurd]

Hello.

I've search this site to try and find the answer but I what I require is a bit more specific than simply copying a list based on a quantity. I'll explain more:

I have a sheet and in this sheet lists tasks in column A, whether they are required or not in column B, The quantity in column C and finally a location (sheet) these tasks need to be copied to in column D. Hopefully, this is a bit clearer:

Task	Required	Qty	Location
Task 1	Y	4	Project Lead
Task 2	Y	4	Project Lead
Task 3	N	3	Mechanical
Task 4	Y	2	Project Lead
Task 5	Y	2	Project Lead
Task 6	Y	1	Project Lead
Task 7	Y	1	Project Lead

<tbody>
</tbody>

I'd like the task (Cell A2), if it is required (Cell B2), to be copied the numbers of times in the Qty column (B3) into the sheet shown in the Location column (Cell B4)

The cell within each sheet that this data is to be copied into will start at Cell D3.

I hope that makes sense.

Regards

Stuart
****** id="cke_pastebin" style="position: absolute; top: 166px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">

Project Lead

<tbody>
</tbody>

</body>

 

[stupurd]

****CORRECTION: (I'm unable to edit posts yet)****

I'd like the task (Cell A2), if it is required (Cell B2), to be copied the numbers of times in the Qty column (C2) into the sheet shown in the Location column (Cell D2)

The cell within each sheet that this data is to be copied into will start at Cell D3.

Regards

Stuart

Edit

 

[stupurd]

Anyone??

 

[My Aswer Is This]

So you only want the values in column A copied to other sheet. Not the entire row.
Is that correct?

 

[My Aswer Is This]

And have all these sheets already been created?

 

[stupurd]

And have all these sheets already been created?

Yes please. Only column A and sheets already exist

 

[My Aswer Is This]

Try this:
Run script from Master sheet

Sub Test()
'Modified 5/1/2018 8:10 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To Lastrow
        If Cells(i, "B").Value = "Y" Then
            Lastrowa = Sheets(Cells(i, "D").Value).Cells(Rows.Count, "D").End(xlUp).Row + 1
            If Lastrowa < 5 Then Lastrowa = 5
            Cells(i, "A").Copy Sheets(Cells(i, "D").Value).Cells(Lastrowa, "D").Resize(Cells(i, 3).Value)
        End If
    Next
Application.ScreenUpdating = True
End Sub

 

[JackDanIce]

Alternate suggestion, try:

Sub MoveData()

    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Master")
         LR = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        arr = .Cells(2, 1).Resize(LR, 4).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        If UCase$(arr(x, 2)) = "Y" Then
            LR = Application.Max(5, Sheets(CStr(arr(x, 4))).Cells(Rows.Count, 4).End(xlUp).Row + 1)
            Sheets(CStr(arr(x, 4))).Cells(LR, 4).Resize(arr(x, 3)).Value = arr(x, 1)
        End If
    Next x
    Erase arr
    
    Application.ScreenUpdating = True
    
End Sub

 

[stupurd]

Try this:
Run script from Master sheet

Sub Test()
'Modified 5/1/2018 8:10 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To Lastrow
        If Cells(i, "B").Value = "Y" Then
            Lastrowa = Sheets(Cells(i, "D").Value).Cells(Rows.Count, "D").End(xlUp).Row + 1
            If Lastrowa < 5 Then Lastrowa = 5
            Cells(i, "A").Copy Sheets(Cells(i, "D").Value).Cells(Lastrowa, "D").Resize(Cells(i, 3).Value)
        End If
    Next
Application.ScreenUpdating = True
End Sub

Thank you very much. This worked perfectly on my test sheet. I had to change the column letters and it worked great on the real spreadsheet (The format of which is a little convoluted, a simple table was created to ask for help). I didn't know that .Resize could be used to paste the number of rows - you learn something new everyday.

Thanks again

Regards

Stuart

 

[stupurd]

Alternate suggestion, try:

Sub MoveData()

    Dim arr()   As Variant
    Dim x       As Long
    Dim LR      As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Master")
         LR = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        arr = .Cells(2, 1).Resize(LR, 4).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        If UCase$(arr(x, 2)) = "Y" Then
            LR = Application.Max(5, Sheets(CStr(arr(x, 4))).Cells(Rows.Count, 4).End(xlUp).Row + 1)
            Sheets(CStr(arr(x, 4))).Cells(LR, 4).Resize(arr(x, 3)).Value = arr(x, 1)
        End If
    Next x
    Erase arr
    
    Application.ScreenUpdating = True
    
End Sub

Thank you!