Copy row to another sheed based on drop-down list

[kyceeq]

Hello, Please I need your assistance with trying to copy active row to another worksheet based on drop-down. I have two worksheets: Requisition & Expenditure list respectively. I want a situation where when I click the drop-down list on Column H in Sheet 'Requisition' and select the option 'Fulfilled' , that particular row from 'B:G' will copy and paste on a new row in the 'Expenditure list' sheet.

I am currently using tables on both sheets and will like to keep it as such. I have tried the code below but it doesn't work

Sub Reqfulfilled()
Dim wsh As Worksheet, wsh2
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
Dim tbl As ListObject, tbl2
Set wsh = Worksheets("REQUISITION")
Set wsh2 = Worksheets("EXPENDITURE LIST")
Set tbl = wsh2.ListObjects("expendituretbl")
Set tbl2 = wsh.ListObjects("requisitiontbl")
A = tbl.Rows.Count
B = tbl2.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("EXPENDITURE LIST").UsedRange) = 0 Then B = 0
End If
Set xRg = wsh.Range("H1:H" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Fulfilled" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("EXPENDITURE LIST").Range("A" & B + 1)
B = B + 1
End If
Worksheets("EXPENDITURE LIST").UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
Worksheets("EXPENDITURE LIST").UsedRange.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
Next
MsgBox ("Data has been entered")
Application.ScreenUpdating = True
End Sub

Any ideas?

 

[igold]

I am not 100% sure what you want to do, but this code will look at your entire request table and copy all rows (which have "fulfilled" in the Status Column) and only the first 6 columns to your expenditure table. It is unclear from your post if you are keeping all your requests as you only show up to Row 38, but on your expenditure table you are showing down to Row 616. The code will rewrite your Expediture Table every time the code is run. Even if this is not exactly what you want, you may find that this method is easier (and probably faster) than what your code is doing and be able to alter it to better suit your needs...
Please test on a backup copy of your work as this code will overwrite data that is not easily recovered.

Sub Reqfulfilled()

    Dim wsh As Worksheet, wsh2 As Worksheet
    Dim xRg As Range
    Dim B As Long, C As Long, col As Long
    Dim tbl As ListObject, tbl2 As ListObject
    Dim arr, arr2
    
    Set wsh = Worksheets("REQUISITION")
    Set wsh2 = Worksheets("EXPENDITURE LIST")
    Set tbl = wsh2.ListObjects("expendituretbl")
    Set tbl2 = wsh.ListObjects("requisitiontbl")

    Application.ScreenUpdating = False
    B = 1
    arr = tbl2.DataBodyRange
    ReDim arr2(1 To tbl.ListRows.Count, 1 To 6)
    Application.ScreenUpdating = False
    For C = 1 To UBound(arr)
        If arr(C, 7) = "Fulfilled" Then
            For col = 1 To 6
                arr2(B, col) = arr(C, col)
            Next
            B = B + 1
        End If
    Next

    wsh2.Range("A4").Resize(UBound(arr2, 1), 6) = arr2
    Set xRg = Range("expendituretbl[#All]").Resize(B, 6)
    tbl.Resize xRg

    MsgBox ("Data has been entered")
    Application.ScreenUpdating = True
    
End Sub

 

[kyceeq]

Thank you for your feedback. So it is not possible to copy only the active row rather than the entire sheet?

 

[igold]

Yes it is possible, I was trying to provide a more effecient solution than what I thought your code was doing. How do you plan on triggering the code.

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your Requisition sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Make a selection in column H.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 8 Then Exit Sub
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, lRow As Long
    Set desWS = Sheets("EXPENDITURE LIST")
    lRow = desWS.Cells(desWS.Cells(1, "A").End(xlDown).Row + 1, "A").Row
    If Target = "Fulfilled" Then
        Range("B" & Target.Row).Resize(, 6).Copy desWS.Range("A" & lRow)
    End If
    Application.ScreenUpdating = True
End Sub

 

[kyceeq]

Hello, thank you once again for your feedback. I tried the last code on the worksheet module...it isn't giving the required result. It only copies the data from the requisition sheet inside of the active cell row

 

[mumps]

copy active row to another worksheet based on drop-down

that particular row from 'B:G' will copy and paste on a new row in the 'Expenditure list

The macro does exactly what you requested. If this is not what you want, please explain in detail using a few examples from your data.