excel - I have 2 macros for moving data between tabs - Stack Overflow

admin管理员组

文章数量:1122846

Both move based on keyword "completed' and "not completed" My table uses columns A to G. Problem is when I use the macro it sometimes puts in an odd row apart from data already there or it will overwrite the data in that row. How do I make it paste data in a new row without overwriting other data in the sheet. Code below:

Sheet code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MoveToCompleted
        End If
    Next
    Application.EnableEvents = True
End Sub

Module

Sub MoveToCompleted()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Master").Range("C1:C" & 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").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

Backwards macro module

Sub MoveToMaster()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Master").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Completed").Range("C1:C" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "not completed" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Master").Range("A1" & B + 1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "not completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

I tried to add .insert.row formula to after Range("A1" & B + 1) but it still would overwrite data or paste in a row much farther down.

Both move based on keyword "completed' and "not completed" My table uses columns A to G. Problem is when I use the macro it sometimes puts in an odd row apart from data already there or it will overwrite the data in that row. How do I make it paste data in a new row without overwriting other data in the sheet. Code below:

Sheet code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MoveToCompleted
        End If
    Next
    Application.EnableEvents = True
End Sub

Module

Sub MoveToCompleted()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Master").Range("C1:C" & 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").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

Backwards macro module

Sub MoveToMaster()
 Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Master").UsedRange.Rows.Count
    B = Worksheets("Completed").UsedRange.Rows.Count
    If A = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Master").UsedRange) = 0 Then A = 0
    End If
    Set xRg = Worksheets("Completed").Range("C1:C" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "not completed" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Master").Range("A1" & B + 1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "not completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

I tried to add .insert.row formula to after Range("A1" & B + 1) but it still would overwrite data or paste in a row much farther down.

• excel
• vba

Share Improve this question Follow edited Nov 21, 2024 at 17:17 Mayukh Bhattacharya 27k88 gold badges2929 silver badges4242 bronze badges asked Nov 21, 2024 at 17:09 Zak KizerZak Kizer 111 bronze badge 3

• Can you elaborate on "odd row"? Is that a blank row, the same data twice, etc. – Cyril Commented Nov 21, 2024 at 17:26
• In a quick look, you have the same macro where you can Select Case if the cell value was changed from "Completed"/"Not Completed", then you can Set the destination sheet as your Case. That should resolve a bit of the runaround... labeling your variables with plain English would also most likely help in the future, where A,B,C will be nice and confusing, considering you're using those same columns. – Cyril Commented Nov 21, 2024 at 17:30
• Is your date in regular ranges, or is it stored as ListObjects/Tables ? – Tim Williams Commented Nov 21, 2024 at 19:18

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 2

Here's one way to do it:

This goes in the ThisWorkbook code module:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim wsComp As Worksheet, wsMaster As Worksheet, rng As Range
    Set wsComp = Me.Worksheets("Completed")
    Set wsMaster = Me.Worksheets("Master")
    
    'exit if not a sheet we're monitoring
    If Sh.Name <> wsComp.Name And Sh.Name <> wsMaster.Name Then Exit Sub
    
    Set rng = Application.Intersect(Sh.Columns("C"), Target)
    If rng Is Nothing Then Exit Sub 'no change in col C
    
    'make a call to transfer any matched rows
    Select Case Sh.Name
        Case wsComp.Name: MoveRows wsComp, wsMaster, "not completed"
        Case wsMaster.Name: MoveRows wsMaster, wsComp, "completed"
    End Select
    
End Sub

This goes in a regular module:

'Copy rows from `fromSheet` to `toSheet`, where value in ColC matches `flagValue`
Sub MoveRows(fromSheet As Worksheet, toSheet As Worksheet, flagValue As String)
    Const FLAG_COL As String = "C"
    Dim rngCopy As Range, lrFrom As Long, lrTo As Long, c As Range
    
    lrFrom = LastOccupiedRow(fromSheet)
    lrTo = LastOccupiedRow(toSheet)
    
    For Each c In fromSheet.Range(fromSheet.Cells(2, FLAG_COL), _
                                  fromSheet.Cells(lrFrom, FLAG_COL)).Cells
        If LCase(c.Value) = LCase(flagValue) Then
            If rngCopy Is Nothing Then
                Set rngCopy = c
            Else
                Set rngCopy = Application.Union(rngCopy, c)
            End If
        End If
    Next c
    
    If Not rngCopy Is Nothing Then 'anything to copy?
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        rngCopy.EntireRow.Copy toSheet.Cells(lrTo + 1, "A") 'copy rows
        rngCopy.EntireRow.Delete 'remove the copied rows
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
    
End Sub

Function LastOccupiedRow(ws As Worksheet) As Long
    Dim f As Range
    Set f = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not f Is Nothing Then LastOccupiedRow = f.Row
End Function

本文标签： excelI have 2 macros for moving data between tabsStack Overflow