Want to paste the data in next row each time i run this macro-CodePudding

I need that when i run this code every time data should be pasted to next row. Salary sheet is raw data file , and final slaary is final sheet where data is to be copied. Please help


Sub TestThat()

'Declare the variables
Dim DataSh As Worksheet
Dim finalSh As Worksheet
Dim monthsRange As Range
Dim rCell As Range
Dim i As Long

'Set the variables
Set DataSh = ThisWorkbook.Sheets("Salary Sheet")
Set finalSh = ThisWorkbook.Sheets("Final Salary")

Set monthsRange = DataSh.Range(DataSh.Cells(3, 1), DataSh.Cells(Rows.Count, 1).End(xlUp))
    'I went from the cell row3/column1 (or a3) and go down until the last non empty cell

    i = 2

    For Each rCell In monthsRange 'loop through each cell in the range

        If rCell = Sheets("Menu").Range("E6").Value Then 'check if the cell is equal to "range e6"

            i = i   1                                'Row number ( 1 everytime I found another "range e6")
            finalSh.Cells(i, 1) = rCell.Offset(0, 0) 'month
            finalSh.Cells(i, 2) = rCell.Offset(0, 1) 'emp id
            finalSh.Cells(i, 3) = rCell.Offset(0, 2) 'emp name
            finalSh.Cells(i, 4) = rCell.Offset(0, 3) 'designation
            finalSh.Cells(i, 5) = rCell.Offset(0, 22) 'gross salary

        End If

    Next rCell

End Sub

CodePudding user response：

I think your error is :

finalSh.Cells(i, 1).Value = rCell.Offset(0, 0).Value 'month
finalSh.Cells(i, 2).Value = rCell.Offset(0, 1).Value 'emp id
finalSh.Cells(i, 3).Value = rCell.Offset(0, 2).Value 'emp name
finalSh.Cells(i, 4).Value = rCell.Offset(0, 3).Value 'designation
finalSh.Cells(i, 5).Value = rCell.Offset(0, 22).Value 'gross salary

So your code might be :

Sub TestThat()

'Declare the variables
Dim DataSh As Worksheet
Dim finalSh As Worksheet
Dim monthsRange As Range
Dim rCell As Range
Dim i As Long

'Set the variables
Set DataSh = ThisWorkbook.Sheets("Salary Sheet")
Set finalSh = ThisWorkbook.Sheets("Final Salary")

Set monthsRange = DataSh.Range(DataSh.Cells(3, 1), DataSh.Cells(Rows.Count, 1).End(xlUp))
    'I went from the cell row3/column1 (or a3) and go down until the last non empty cell

    i = 2

    For Each rCell In monthsRange 'loop through each cell in the range

        If rCell = Sheets("Menu").Range("E6").Value Then 'check if the cell is equal to "range e6"

            i = i   1 'Row number ( 1 everytime I found another "range e6")
    finalSh.Cells(i, 1).Value = rCell.Offset(0, 0).Value 'month
    finalSh.Cells(i, 2).Value = rCell.Offset(0, 1).Value 'emp id
    finalSh.Cells(i, 3).Value = rCell.Offset(0, 2).Value 'emp name
    finalSh.Cells(i, 4).Value = rCell.Offset(0, 3).Value 'designation
    finalSh.Cells(i, 5).Value = rCell.Offset(0, 22).Value 'gross salary

        End If

    Next rCell

End Sub

CodePudding user response：

Copy Criteria Rows

A quick fix would probably be, instead of i = 2, to use:

i = finalSh.Cells(finalSh.Rows.Count, 1).End(xlUp).Row

Here's a more flexible way to do it.

Option Explicit

Sub CopyCriteriaRows()

    ' Source
    Const sName As String = "Salary Sheet"
    Dim sCols As Variant: sCols = Array("A", "B", "C", "D", "W") ' read
    Const slrCol As String = "A" ' Source Last Row Column
    Const sCol As String = "A" ' Source (Criteria) Column
    Const sfRow As String = 3
    ' Destination
    Const dName As String = "Final Salary"
    Dim dCols As Variant: dCols = Array("A", "B", "C", "D", "E") ' write
    Const dlrCol As String = "A"
    ' Criteria
    Const cName As String = "Menu"
    Const cCellAddress As String = "E6"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data in column range
    Dim slrg As Range ' Source Last Row Column Range
    Set slrg = sws.Range(sws.Cells(sfRow, slrCol), sws.Cells(slRow, slrCol))
    Dim srg As Range: Set srg = slrg.EntireRow.Columns(sCol)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlrCol).End(xlUp).Row
    Dim dCell As Range: Set dCell = dws.Cells(dlRow   1, dlrCol)
    
    ' Criteria
    Dim cws As Worksheet: Set cws = wb.Worksheets(cName)
    Dim cCell As Range: Set cCell = cws.Range(cCellAddress)
    Dim Criteria As String: Criteria = CStr(cCell.Value)
    
    ' Other
    Dim nLower As Long: nLower = LBound(sCols)
    Dim nUpper As Long: nUpper = UBound(sCols)
    
    Dim sCell As Range
    Dim n As Long

    ' Read/Write.
    For Each sCell In srg.Cells
        If StrComp(CStr(sCell.Value), Criteria, vbTextCompare) = 0 Then
            For n = nLower To nUpper
                dCell.EntireRow.Columns(dCols(n)).Value _
                    = sCell.EntireRow.Columns(sCols(n)).Value
            Next n
            Set dCell = dCell.Offset(1)
        End If
    Next sCell

    ' Inform.
    MsgBox "Month '" & Criteria & "' processed.", vbInformation

End Sub