Macros to Copy Certain Rows from One Workbook to Another Workbook

[rajeshapril14]

Hi, I have similar issue, But I want needs to copy if it contains "Approved" "Rejected" "Hold".

But below is accepting only "Approved" how to add other 2. If copy non-blanks also ok for me.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        With Target
            If .Count > 1 Then Exit Sub
            If Not Intersect(Range("U:U"), .Cells) Is Nothing Then
                Application.EnableEvents = False
                If IsEmpty(.Value) Then
                    .Offset(0, -1).ClearContents
                Else
                    With .Offset(0, -1)
                        .NumberFormat = "dd mmm yyyy"
                        .Value = Now
                    End With
                End If
                Application.EnableEvents = True
            End If
        End With
        If Target.Column <> 21 Then Exit Sub
        If Target.Text <> "Approved" Then Exit Sub
        Application.ScreenUpdating = False
        Dim oSH1 As Worksheet
        Set oSH1 = ThisWorkbook.ActiveSheet
        Dim wbCallLogs As Workbook
        Set wbCallLogs = Workbooks.Open("C:\Rajesh Kanna\Tools\Copy range to different workbook\Data.xls")
        Dim oSH As Worksheet
        Set oSH = wbCallLogs.Worksheets("Calls")
        Dim r As Long
        r = oSH.Cells(oSH.Rows.Count, 21).End(xlUp).Row + 1
        oSH.Range(r & ":" & r).Value = oSH1.Range(Target.Row & ":" & Target.Row).Value
        wbCallLogs.Close (True)
    End Sub

[Kelshaer]

Try this:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
 With Target
 If .Count > 1 Then Exit Sub
 If Not Intersect(Range("U:U"), .Cells) Is Nothing Then
 Application.EnableEvents = False
 If IsEmpty(.Value) Then
 .Offset(0, -1).ClearContents
 Else
 With .Offset(0, -1)
 .NumberFormat = "dd mmm yyyy"
 .Value = Now
 End With
 End If
 Application.EnableEvents = True
 End If
 End With
 If Target.Column <> 21 Then Exit Sub
 If Target.Text = "Approved" Or Target.Text = "Rejected" Or Target.Text = "Hold" Then
    Application.ScreenUpdating = False
    Dim oSH1 As Worksheet
    Set oSH1 = ThisWorkbook.ActiveSheet
    Dim wbCallLogs As Workbook
    Set wbCallLogs = Workbooks.Open("C:\Rajesh Kanna\Tools\Copy range to different workbook\Data.xls")
    Dim oSH As Worksheet
    Set oSH = wbCallLogs.Worksheets("Calls")
    Dim r As Long
    r = oSH.Cells(oSH.Rows.Count, 21).End(xlUp).Row + 1
    oSH.Range(r & ":" & r).Value = oSH1.Range(Target.Row & ":" & Target.Row).Value
    wbCallLogs.Close (True)
 End If
 End Sub

[rajeshapril14]

Thanks Kalshaer. Its working great. I am breaking my heads for last 6 hours. I am not good on Excel.

[rajeshapril14]

Hi Kalshaer, Hope you are doing good.

Need your help once again. In the below once selection done in column "U", it will date and time automatically in column "T" and copy the list of info to another workbook. Until that no problem for me.

I need to add lock option. Once any choice is selected in "U"and copied I want the cell needs to be lock to avoid further selection in single cell. Based on below, it is not happening. Pls help.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
 With Target
 If .Count > 1 Then Exit Sub
 If Not Intersect(Range("U:U"), .Cells) Is Nothing Then
 Application.EnableEvents = False
 If IsEmpty(.Value) Then
 .Offset(0, -1).ClearContents
 Else
 With .Offset(0, -1)
         .NumberFormat = "dd mmm yyyy hh:mm:ss"
         .Value = Now
 End With
 End If
 Application.EnableEvents = True
 End If
 End With
 If Target.Column <> 21 Then Exit Sub
 If Target.Text = "Approved" Or Target.Text = "Rejected" Or Target.Text = "Hold" Then
    Application.ScreenUpdating = False
    Dim oSH1 As Worksheet
    Set oSH1 = ThisWorkbook.ActiveSheet
    Dim wbCallLogs As Workbook
    Set wbCallLogs = Workbooks.Open("C:\Rajesh Kanna\Tools\Copy range to different workbook\Data.xls")
    Dim oSH As Worksheet
    Set oSH = wbCallLogs.Worksheets("Calls")
    Dim r As Long
    r = oSH.Cells(oSH.Rows.Count, 21).End(xlUp).Row + 1
    oSH.Range(r & ":" & r).Value = oSH1.Range(Target.Row & ":" & Target.Row).Value
    wbCallLogs.Close (True)
    End If
 
 'Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("t1:t10")) Is Nothing Then 'set your range here
        ActiveSheet.Unprotect Password:="123"
        Target.Locked = True
        ActiveSheet.Protect Password:="123"
    End If
End Sub

[Cutter]

@ rajeshapril14

Welcome to the forum.

Please notice that code tags have been added to your posts. The forum rules require them so please keep that in mind and add them yourself whenever showing code in any of your future posts. To see instructions for applying them, click on the Forum Rules button at the top of the page and read Rule #3.
Thanks.