vba loop in order to copy specific cells from one sheet to another-CodePudding

i am quite new to VBA. I need to copy specific ID numbers from one Sheet to another. The structure of the table is always the same and ID numbers are always in same place, starting from cell B8, then B29, B50, B(n 21) so on.... I recorded the following Macro and i need to write a simple loop (cycle)

Sub Macro3()

    ActiveCell.FormulaR1C1 = "=Hoja1!R[-4]C2"
    Range("A13").Select
    
    ActiveCell.FormulaR1C1 = "=Hoja1!R[16]C2"
    Range("A14").Select
    
    ActiveCell.FormulaR1C1 = "=Hoja1!R[36]C2"
    Range("A15").Select
    
    ActiveCell.FormulaR1C1 = "=Hoja1!R[56]C2"
    Range("A16").Select
    
End Sub

CodePudding user response：

Copy Cell Values With Offset

Sub CopyIds()
 
    ' Source
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "B8"
    Const sRowOffset As Long = 21
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A13"
    Const dRowOffset As Long = 1
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim sFirstRow As Long
    Dim sColumn As Long
    
    With sws.Range(sFirstCellAddress)
        sFirstRow = .Row
        sColumn = .Column
    End With
    
    Dim sLastRow As Long
    sLastRow = sws.Cells(sws.Rows.Count, sColumn).End(xlUp).Row
    If sLastRow < sFirstRow Then Exit Sub ' no data in source column range
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    Dim dCell As Range: Set dCell = dws.Range(dFirstCellAddress)
    
    ' Write.
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    Dim sRow As Long
     
    For sRow = sFirstRow To sLastRow Step sRowOffset
        Set sCell = sws.Cells(sRow, sColumn) ' reference current source cell
        dCell.Value = sCell.Value ' write
        Set dCell = dCell.Offset(dRowOffset) ' reference next destination cell
    Next sRow
    
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Ids copied.", vbInformation
    
End Sub