none
VBA code to cut and paste rows from one sheet to anothersheet based on condition RRS feed

  • Question

  • Dear all,

    Let me put my request more clear. I need the VBA code, if I click the button i would like to select the rows containing the values 'APCW2' (not exactly but only containing/starting with APCW2) in the column 'Emp Code' and cut and paste in the new sheet of the same workbook. This is what I look at exactly. Pls help me out.

    Unit	Emp Code
    A 	APCW1940014484
    A 	APCW1940014485
    A 	APCW1940014486
    A 	APCW1940014487
    A 	APCW1940014488
    A 	APCW2940002306
    A 	APCW2940002312
    A 	APCW2940002313
    A 	APCW2940002314
    A 	APCW2940002316
    A 	APCW2940002319
    A 	APCW2940002323
    A 	APCW2940002325
    A 	APCW2940002392
    A 	APCW2940003215
    A 	APCW2940003216
    A 	APCW2940003218
    A 	APCW2940003220
    

    
    Friday, March 16, 2018 6:24 AM

All replies

  • For example:

    Sub CutAndPaste()
        Const c = 2 ' Emp Code column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim s As Long
        Dim m As Long
        Dim t As Long
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        Set wshT = Worksheets.Add(After:=wshS)
        m = wshS.Cells(wshS.Rows.Count, c).End(xlUp).Row
        For s = m To 2 Step -1
            If wshS.Cells(s, c).Value Like "APCW2*" Then
                t = t + 1
                With wshS.Cells(s, c).EntireRow
                    .Copy Destination:=wshT.Cells(t, 1)
                    .Delete
                End With
            End If
        Next s
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, March 16, 2018 9:52 AM
  • Hi sarisri,

    Below is an another example to achieve the same.

    Sub demo()
        Dim c As Range
        Dim j As Integer
        Dim Source As Worksheet
        Dim Target As Worksheet
        Dim i As Long
        Dim sht As Worksheet
        Dim LastRow As Long
    
    Set sht = ActiveSheet
    LastRow = sht.Cells(sht.Rows.Count, "c").End(xlUp).Row
    
     
        Set Source = ActiveWorkbook.Worksheets("Sheet1")
        Set Target = ActiveWorkbook.Worksheets("Sheet2")
      
        j = 1
        For Each c In Source.Range("C1:C" & LastRow)
            If c Like "*APCW2*" Then
               Source.Rows(c.Row).Cut Target.Rows(j)
               j = j + 1
            End If
        Next c
    End Sub

    Output:

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, March 19, 2018 2:55 AM
    Moderator
  • Hi sarisri,

    Is your issue is solved now?

    I find that you did not done any follow up after creating this thread.

    If your issue is fixed by you then I suggest you to post your solution and mark it as an answer.

    If your issue is still exist then try to refer the suggestions given by the community members.

    If you think that the suggestions given by the community member can solve your issue then mark the helpful suggestion as an answer.

    It will help us to close this thread and it also can be helpful to other community members who will meet with same kind of issues in future.

    If you have any further questions then you can let us know about it, We will try to provide you further suggestions to solve it.

    I suggest you to update the status of this thread and take appropriate actions to close it.

    Thanks for your understanding.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, March 21, 2018 9:52 AM
    Moderator