I am writing vba code to copy one row of data at a time from one sheet and pasting into another sheet

Question

I am writing vba code to copy one row of data at a time from one sheet and pasting into another sheet. I need to repeat this 100 times. I also need to modifying couple of column values after pasting them. However, my data is not pasting into new sheet correctly.

'Get column numbers which need to be modified
PolicyReference = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("PolicyReference").Column
InsuredCode = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("InsuredCode").Column
InsuredDescription = DataWS.Range("A1", DataWS.Range("IV1").End(xlToLeft)).Find("InsuredDescription").Column


For j = 1 To 100
    'Worksheets(DataWS).Range("A1:A100").Copy Worksheets(DestinationWS).Range("A1")
    CopyLastRow = DataWS.Cells(DataWS.Rows.count, "A").End(xlUp).Row         '1. Find last used row in the copy range based on data in column A
    DestLastRow = DestinationWS.Cells(DestinationWS.Rows.count, "A").End(xlUp).Offset(1).Row         '2. Find first blank row in the destination range based on data in column A
    DataWS.Rows(j).EntireRow.Copy DestinationWS.Range("A" & DestLastRow) '3. Copy & Paste Data
    DataWS.Range("A1:A100").Copy
    DestinationWS.Range("A" & Rows.count).End(xlUp).Offset(2).PasteSpecial Paste:=xlPasteValues
Next j

Answer 1

This code will copy all but the first row from DataWs to DestinationWs . If you want to be more selective in what you copy modifications must be made to the code in the loop, at the bottom.

Private Sub Study()
    ' 244

    Dim DataWs              As Worksheet
    Dim DestinationWs       As Worksheet
    Dim PolicyReference     As Long
    Dim InsuredCode         As Long
    Dim InsuredDescription  As Long
    Dim Fnd                 As Range
    Dim CopyLastRow         As Long
    Dim DestLastRow         As Long
    Dim R                   As Long                 ' loop counter: rows
    
    Set DataWs = Worksheets("Sheet1")
    Set DestinationWs = Worksheets("Sheet2")
    
    With DestinationWs
        DestLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    'Get column numbers which need to be modified
    With DataWs
        Set Fnd = .Rows(1).Find("PolicyReference")          ' spaces between words are permissible
        ' make sure the column is found before using it in your further code
        If Fnd Is Nothing Then Exit Sub
        PolicyReference = Fnd.Column
        
        Set Fnd = .Rows(1).Find("InsuredCode")
        If Fnd Is Nothing Then Exit Sub                     ' perhaps give a message before exiting
        InsuredCode = Fnd.Column
        
        Set Fnd = .Rows(1).Find("InsuredDescription")
        If Fnd Is Nothing Then Exit Sub                     ' perhaps give a message before exiting
        InsuredDescription = Fnd.Column
        
        CopyLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Application.ScreenUpdating = False                  ' speeds up execution
        For R = 2 To CopyLastRow                            ' start in row 2
            DestLastRow = DestLastRow + 1
            .Rows(R).Copy DestinationWs.Cells(DestLastRow, "A")
        Next R
        Application.ScreenUpdating = True
    End With
End Sub

Answer 2

Columns and Ranges

• I am considering these as two problems. Revealing the connection between them might lead to a more suitable solution.
• The first part (including the function) illustrates how you can write the column numbers to an array which can later be used to process the data in those columns.
• The second part illustrates how to copy values most efficiently. The loop is ignored.

Option Explicit

Sub ColumnsAndRanges()
    
    Const sName As String = "Sheet1"
    Const shRow As Long = 1
    Const sHeadersList As String _
        = "PolicyReference,InsuredCode,InsuredDescription"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    
    'Part 1: Column Numbers
    
    Dim shrg As Range: Set shrg = sws.Rows(shRow)
    
    ' Use the function 'getColumnNumbers'.
    Dim sColNums As Variant: sColNums = getColumnNumbers(shrg, sHeadersList)
    If IsEmpty(sColNums) Then
        MsgBox "Could not find all the headers."
        Exit Sub
    End If
    
    ' Column Numbers Example:
    Dim n As Long
    For n = 1 To UBound(sColNums)
        Debug.Print n, sColNums(n)
    Next n
        
        
    'Part 2: Copy Range Values
    
    ' Create a reference to the Source Range.
    Dim slCell As Range ' Source Last Cell
    Set slCell = sws.Cells(sws.Rows.Count, "A").End(xlUp)
    Dim srg As Range
    ' Note how a cell address (sFirst) or a cell range (slCell) can be used.
    Set srg = sws.Range(sFirst, slCell).EntireRow
    
    ' Create a reference to the Destination Range.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range ' Destination First Cell
    ' When 'EntireRow' is used, only "A" or 1 can be used.
    Set dfCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
    
    ' Copy by assignment (most efficient when only values are to be copied).
    drg.Value = srg.Value

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the column numbers in a one-based array.
' Remarks:      The column numbers refer to the columns of the given range,
'               not necessarily to the columns of the worksheet.
'               If any of the headers cannot be found, 'Empty' is returned.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnNumbers( _
    ByVal RowRange As Range, _
    ByVal HeadersList As String, _
    Optional ByVal Delimiter As String = ",") _
As Variant
        
    If RowRange Is Nothing Then Exit Function
    If Len(HeadersList) = 0 Then Exit Function
        
    Dim Headers() As String: Headers = Split(HeadersList, Delimiter)
    Dim ColNums As Variant
    ColNums = Application.Match(Headers, RowRange.Rows(1), 0)
    If Application.Count(ColNums) = UBound(Headers) + 1 Then
        getColumnNumbers = ColNums
    End If
    
End Function

Answer 3

The following one line of code using AdvancedFilter will paste data to the destination sheet.

Sub CopyDataToAnotherSheet()

DataWS.Range("A1").CurrentRegion.AdvancedFilter _
    Action:=xlFilterCopy, _
    CriteriaRange:=DataWS.Range("A1", _
    DataWS.Cells(1, DataWS.Columns.Count).End(xlToLeft)), _
    CopyToRange:=DestinationWS.Range("A1")

End Sub