VBA Copy from Dynamic Range - Paste to another Sheet

lemanstom

New Member
Joined
Nov 29, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Hi
Relative noob, new to the forum at least, so please excuse my ignorance. I have a workbook with multiple sheets, 2 of which I need to copy data from and to (only one way).

Basically the source sheet contains a dynamic list of 'Products' in Column A, a Quantity of said product in Column B, then Column C contains another Quantity. I'm trying to loop down through Column C to find any cells with a quantity in, then copy that value over to the Destination sheet Column G, starting in cell G6. Then I need it to copy and paste the relevant 'Product' name from the row in Source Column A to Destination Column A (same row as the quantity that's been copied). Currently have it all triggered by a commandbutton for testing...

Using the following code I've been successful in copying the first product found, but it seems to stop after this, it doesn't iterate/loop down through the column until no further quantities are found.

I hope I've explained that in enough detail, and it makes some sense! o_O

Any help any of you clever people can provide will be gratefully received. I've spent so much time reading through other threads on multiple forums with no joy. I'm betting it's a simple fix, but I'm blind to what it might be :(
Here's the code I've been using:
VBA Code:
Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False
      
    Dim shSource As Worksheet, shDest As Worksheet, sourceRng As Range, sourceCell As Range, lr As Long
    Dim i As Integer
    ' Set Source Sheet
    Set shSource = Me.Parent.Worksheets("SourceSheet")
    'Set Destination Sheet
    Set shDest = Me.Parent.Worksheets("DestinationSheet")
    'Find Last Row on Source Sheet
    lr = shSource.Cells(Rows.Count, 1).End(xlUp).Row
    'Set Source Sheet Range
    Set sourceRng = shSource.Range("C2:C" & lr)
    'Find Next Empty Cell of Column G on Destination Sheet
    nextFreeCell = shDest.Range("G6:G" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    
    'Loop to copy data from Source to Destination
    For Each sourceCell In sourceRng
        If sourceCell.Value > 0 Then
            shDest.Range("G" & nextFreeCell).Value = sourceCell.Value
            shDest.Range("A" & nextFreeCell).Value = sourceCell.Offset(, -2).Value
        End If
    Next sourceCell
           
    Application.ScreenUpdating = True
    
End Sub
 

Some videos you may like

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

lemanstom

New Member
Joined
Nov 29, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Sorry, probably would help to have a simple screenshot of the idea...
 

Attachments

  • source-sheet.jpg
    source-sheet.jpg
    36.9 KB · Views: 8
  • destination-sheet.jpg
    destination-sheet.jpg
    38.2 KB · Views: 8

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,317
Office Version
  1. 365
Platform
  1. Windows
You need to increment next row inside the loop, otherwise it will continually overwrite the same cell
VBA Code:
        If sourceCell.Value > 0 Then
            shDest.Range("G" & nextFreeCell).Value = sourceCell.Value
            shDest.Range("A" & nextFreeCell).Value = sourceCell.Offset(, -2).Value
            nextFreeCell = nextFreeCell + 1
        End If
 
Solution

lemanstom

New Member
Joined
Nov 29, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
You need to increment next row inside the loop, otherwise it will continually overwrite the same cell
VBA Code:
        If sourceCell.Value > 0 Then
            shDest.Range("G" & nextFreeCell).Value = sourceCell.Value
            shDest.Range("A" & nextFreeCell).Value = sourceCell.Offset(, -2).Value
            nextFreeCell = nextFreeCell + 1
        End If
Fluff! Well as far as first experiences go, this was amazing! Thank you so much, I'm very grateful, I knew it was going to be a simple one-liner but my brain was fried.

Appreciate that, it works perfectly now :)
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,317
Office Version
  1. 365
Platform
  1. Windows
Glad to help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,388
Messages
5,601,373
Members
414,447
Latest member
CRAVIN

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