直到循环停止

Question

I am trying to use a 'Do Until' loop to take a value from list (Drop-down fields worksheet, starting at cell B19) and update a cell value another Excel Sheet (specifically, Data Collection worksheet, cell C1). Once I can get this to work, I will add already functioning code to save the file based on the value in C1 in the Data Collection worksheet.

I am testing the code but it is constantly getting stuck after the pulling that first value. Basically, it doesn't actually loop through the list until it ends.

I believe it has to do with what is classified as the active cell. I think when I paste the value that changes the active cell. I tried to correct this by re-iterating the active cell again. This might be creating an infinite loop though.

Is there something I can do to adjust this? Thank you in advance for looking at this and any replies you might have! I based structure on the documentation found at https://docs.microsoft.com/en-us/office/troubleshoot/excel/loop-through-data-using-macro

Code below:

   Sub Test2()
    ' Select cell to start loop, *first line of data*.
      Worksheets("Drop-down fields").Activate
      Range("B19").Select
      Worksheets("Drop-down fields").Range("B19").Copy
      ' Set Do loop to stop when an empty cell is reached.
      Do Until IsEmpty(ActiveCell)
      Worksheets("Data Collection").Range("C1").PasteSpecial Paste:=xlPasteValues
      Worksheets("Drop-down fields").Activate
      Range("B19").Select
         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
      Loop
   End Sub

Answer 1

Samuel,

Here's your code refactored to remove all the activates and selects and incrementing through you list in col B and copying to col C.

  Sub Test2()
   
      Dim wksSrc  as Worksheet
      Dim wksDst  as Worksheet
      Dim lSrcRow as Long
      Dim lDstRow as Long
      
      Set wksSrc = Worksheets("Drop-down fields")
      Set wksDst = Worksheets("Data Collection")
      lSrcRow = 19
      lDstRow = 1
      
      Do 
        wksSrc.cells(lSrcRow,2).Copy
        wksDst.Cells(lDstRow,3).PasteSpecial Paste:=xlPasteValues
        lSrcRow = lSrcRow + 1
        lDstRow = lDstRow + 1
      Loop Until wksSrc.cells(lSrcRow,lSrcCol) = ""
      
   End Sub 'Test2

Note: code is untested but I think I got all the references right. HTH