Forum Discussion

ACharles2's avatar
ACharles2
Copper Contributor
Sep 10, 2024

Help needed to create a VBA macro for moving data to and from other worksheets

Hi all,

 

I'm trying to create a project workload workbook which has a list of ongoing projects in one worksheet and a separate worksheet for completed projects. I'd like to automatically move a project from the 'ongoing' sheet to the 'completed' sheet by simply selecting 'completed' in the status column. I'd like for this project to move onto the next available row in the 'completed' worksheet. I'd also like to be able to move the project back into 'ongoing' sheet should the status "completed" have been selected in error. 

 

Please can anyone help me write the correct VBA code to do this? Please find below code which I've recently attempted but found it isn't triggered when selecting the project status (I have to run the macro manually) and when I do, it either moves the project data onto a random row (albeit on the correct sheet), or throws up the VBA window highlighting a section of the code with no explanation as to why it's an issue! 

 

Any help will be very much appreciated.

 

Many thanks in advance, Abi.

'Module Code attempted (but does not work!):'

Sub MoveBasedOnValue()
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Ongoing Mechanical Projects").UsedRange.Rows.Count
    B = Worksheets("Completed Schemes 2024-2025").UsedRange.Rows.Count
    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Completed Schemes 2024-2025").UsedRange) = 0 Then B = 0
    End If
    Set xRg = Worksheets("Ongoing Mechanical Projects").Range("L:L" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "Completed" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Completed Schemes 2024-2025").Range("A" & B + 1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "Completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

'Sheet Code attempted (but does not work!):'
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("L:L")) Is Nothing Then
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MoveBasedOnValue
        End If
    Next
    Application.EnableEvents = True
    End If
End Sub

 

Macros and VBA

2 Replies

Sort By
  • JKPieterse's avatar
    JKPieterse
    Silver Contributor
    Sep 10, 2024

    ACharles2 OK, here is my attempt.

     

    This goes in the code module behind the worksheet:

    Option Explicit

'This should work
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Not Intersect(Target, Range("L:L")) Is Nothing Then
        Application.EnableEvents = False
        MoveBasedOnValue Target
        Application.EnableEvents = True
    End If
End Sub

    And this in a normal module:

    Option Explicit

'Module Code (worked for me)

Sub MoveBasedOnValue(xRg As Range)
    Dim B As Long
    Dim rngArea As Range
    Dim cl As Range
    Dim rng2Delete As Range
    B = Worksheets("Completed Schemes 2024-2025").UsedRange.Rows.Count
    If B = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("Completed Schemes 2024-2025").UsedRange) = 0 Then B = 0
    End If
    On Error Resume Next
    Application.ScreenUpdating = False
    'If non-adjacent cells have been selected, we have to loop through the areas
    For Each rngArea In xRg.Areas
        'Then we loop through the cells in each area
        For Each cl In rngArea.Cells
            If CStr(cl.Value) = "Completed" Then
                'We have a hit, add this to a range of cells that need to be copied below
                If rng2Delete Is Nothing Then
                    Set rng2Delete = cl
                Else
                    Set rng2Delete = Union(rng2Delete, cl)
                End If
            End If
        Next
    Next
    'There are cells to move. Do them all in two single statements
    If Not rng2Delete Is Nothing Then
        rng2Delete.EntireRow.Copy Destination:=Worksheets("Completed Schemes 2024-2025").Range("A" & B + 1)
        rng2Delete.EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub

     

    • ACharles2's avatar
      ACharles2
      Copper Contributor
      Sep 11, 2024
      This does work to the extent where the project data will move from 'Ongoing Mechanical Projects' to 'Completed Schemes 2024-25' when the status "completed" is selected - thank you! Now I'd like to be able to move the data back, should the "completed" status have been selected in error. Any chance you can help me with this next step please?

Resources