VBA macro code to move data from one Excel Worksheet to another Worksheet within the same Workbook

[Win7]

Hi All,

I am a beginner in VBA Excell scripting.

My requirement is as follows:

I have a Excel workbook with two sheets - 'MainDataSheet' and 'ArchiveSheet' .

The 'MainDataSheet' has 5 columns and one of the column is 'status'.

The 'MainDataSheet' will have a command button 'MoveData' which will trigger the VBA macro to move data rows from 'MainDataSheet' to 'ArchiveSheet' . Only the rows having value set to "MOVE" in the 'status' column have to be moved.

Can anyone please help me with the code.

Thanks,

Win7

 

[VoG]

Sorry, I have no experience of working with that type of list.

 

[Win7]

Hi VoG,

This in regard to our previous posts that we had on the topic "VBA macro code to move data from one Excel Worksheet to another Worksheet within the same Workbook "

The code that you had provided works well when the excel sheet has rows to move to another sheet. If there are no matching criteria, then I get a run time error and eisting rows dissapear from main sheet. Autofilter will be applied to all the columns. I have to manually remove these autofilters to view the data again.

This is the code that you had provided.

Sub Shift()
Dim r As Range, LR As Long
With Sheets("MainDataSheet")
LR = .Range("A" & Rows.Count).End(xlUp).Row
Set r = .Range("A2").Resize(LR - 1)
.Range("A1").AutoFilter field:=5, Criteria1:="MOVE"
.Range("A1").AutoFilter field:=4, Criteria1:="EUROPE"
With r.SpecialCells(xlCellTypeVisible).EntireRow
.Copy Destination:=Sheets("ArchiveSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Delete
End With
.Range("A1").AutoFilter
End With
With Sheets("ArchiveSheet")
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A2:E" & LR).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub

Can you please help me to fix this bug?

Thanks and Regards,
Win7

 

[VoG]

Try

Sub Shift()
Dim r As Range, LR As Long
Dim F1 As Range, F2 As Range
With Sheets("MainDataSheet")
    Set F1 = .Columns("E").Find(what:="MOVE", LookIn:=xlValues, lookat:=xlWhole)
    Set F2 = .Columns("D").Find(what:="EUROPE", LookIn:=xlValues, lookat:=xlWhole)
    If F1 Is Nothing Or F2 Is Nothing Then
        MsgBox "Nothing found", vbExclamation
        Exit Sub
    End If
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    Set r = .Range("A2").Resize(LR - 1)
    .Range("A1").AutoFilter field:=5, Criteria1:="MOVE"
    .Range("A1").AutoFilter field:=4, Criteria1:="EUROPE"
    With r.SpecialCells(xlCellTypeVisible).EntireRow
        .Copy Destination:=Sheets("ArchiveSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Delete
    End With
    .Range("A1").AutoFilter
End With
With Sheets("ArchiveSheet")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A2:E" & LR).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub

 

[Win7]

Thanks VoG.

It works fine now

 

[Danron]

Vog,

I figured out the form problem but would now like the form to close and give a msbbox telling you what it moved. I would prefer that the message box tell you that it moved by pulling the name from column 1 (first name) and column2 (last name). For example, if Dan is in column one and Jones is in column 2, then the msgbox will say Dan Jones moved to inspection.
Here is what I have so far.

Private Sub OKButton_Click()
Sheets("Customer Contact").Activate
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
'Application.WorksheetFunction.CountA (Range("A:A")) + 1
Cells(NextRow, 1) = TextName.Text
Cells(NextRow, 2) = TextLastName.Text
Cells(NextRow, 3) = TextAddress.Text
Cells(NextRow, 4) = TextPhone1.Text
Cells(NextRow, 5) = TextPhone2.Text
Cells(NextRow, 6) = TextReferral.Text
Cells(NextRow, 7) = TextInspection.Text
TextName.Text = ""
TextName.SetFocus
Unload UserForm1
Loop
MsgBox cnt & "customers moved to Inspection"
End Sub

 

[Win7]

Sub Shift()
Dim r As Range, LR As Long
Dim F1 As Range, F2 As Range
With Sheets("MainDataSheet")
Set F1 = .Columns("E").Find(what:="MOVE", LookIn:=xlValues, lookat:=xlWhole)
Set F2 = .Columns("D").Find(what:="EUROPE", LookIn:=xlValues, lookat:=xlWhole)
If F1 Is Nothing Or F2 Is Nothing Then
MsgBox "Nothing found", vbExclamation
Exit Sub
End If
LR = .Range("A" & Rows.Count).End(xlUp).Row
Set r = .Range("A2").Resize(LR - 1)
.Range("A1").AutoFilter field:=5, Criteria1:="MOVE"
.Range("A1").AutoFilter field:=4, Criteria1:="EUROPE"
With r.SpecialCells(xlCellTypeVisible).EntireRow
.Copy Destination:=Sheets("ArchiveSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Delete
End With
.Range("A1").AutoFilter
End With
With Sheets("ArchiveSheet")
LR = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A2:E" & LR).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub


Hi VoG,

The above highlighted part was provided by you as a fix to data moving function. IT works fine when there are no data in the Mainpage to be moved to Archive sheet.

Suppose there are two rows:

1. First row has Column D = 'Europe' but Column E <> 'Move'
2. Second row has column D <> 'Europe' but Column E = 'Move' .

In this case, the control skips this check and tries to move the data. But since we have the criteria that Column D = 'Europe' and Column E = 'Move', it will not be able to move the data to ARCHIVE sheet and hence crashes.

Can you please help me out with this?

Thanks,

Win 7

 

[VoG]

Maybe

Sub Shift()
Dim r As Range, LR As Long, i As Long, mtch As Boolean
With Sheets("MainDataSheet")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LR
        If .Range("D" & i).Value = "EUROPE" And .Range("E" & i) = "MOVE" Then
            mtch = True
            Exit For
        End If
    Next i
    If Not mtch Then
        MsgBox "Nothing found", vbExclamation
        Exit Sub
    End If
    Set r = .Range("A2").Resize(LR - 1)
    .Range("A1").AutoFilter field:=5, Criteria1:="MOVE"
    .Range("A1").AutoFilter field:=4, Criteria1:="EUROPE"
    With r.SpecialCells(xlCellTypeVisible).EntireRow
        .Copy Destination:=Sheets("ArchiveSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Delete
    End With
    .Range("A1").AutoFilter
End With
With Sheets("ArchiveSheet")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A2:E" & LR).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub

 

[Win7]

Thanks VoG. The issue is fixed now.

Kind Regards,

Win7