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

Win7 · Jan 15, 2010

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

WaterGypsy · Jan 15, 2010

I'd sdo that by filtering the data on the source sheet to only show those with "MOVE", select the range and then use the following:
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com

ffice

ffice" /><o

></o

>
Selection.SpecialCells(xlCellTypeVisible).Copy _<o

></o

>
Destination:=Workbooks(ThisWorkbook.Name).Sheets("Destination Sheet").Range("A1")

xlCellTypeVisible means you only copy the cells that can be seen

good luck

Win7 · Jan 15, 2010

Thanks WaterGypsy

But I would not like to filter manually and then click the button. I want to create a automated archiving functionality in the spread sheet. The data should be moved with a single click of the button.

Kind Regards,

Win 7

VoG · Jan 15, 2010

This assumes that the status column is column E

Code:

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"
    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
End Sub

Win7 · Jan 15, 2010

Thanks VoG.

There are 3 more things that I would require:

1. I want to MOVE the data permanently from 'MainDataSheet' instead of copying the data. Then there is one more criteria. Suppose if the 4th Column is 'Address' , then I have to move all rows which have 'Address' = "EUROPE" and 'Status' = "MOVE".

2. The second sheet, 'ArchiveSheet' may be already having data. So, I have to move the rows from 'mainDataSheet' to the last available row of 'ArchivSheet' .

3. After moving the row to 'ArchiveSheet', the rows in the 'ArchiveSheet' has to be sorted by a column, say 'SerialNumber' which will be the first column in both the sheets.

Thanks,

Win 7

VoG · Jan 15, 2010

Try

Code:

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

Win7 · Jan 15, 2010

Thanks VoG

. Will try this code..

VoG · Jan 15, 2010

Missed a dot

Rich (BB code):

    .Range("A2:E" & LR).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Win7 · Jan 15, 2010

Thanks VoG. But the code is not working fine.

On the click of the Button, the data rows matching the criteria are not moved to 'ArchiveSheet' and remains in the 'MainDataSheet'.

All the other rows which do not meet the filtering criteria gets invisible from the 'MainDataSheet'. The 'AutoFilter' is turned ON automatically on the click of the button running this code. The rows become visible only when I remove the 'AutoFilter' option manually.

Can you please suggest me any changes required in the code?

Thanks,

Win7

VoG · Jan 15, 2010

Before the code

<b>MainDataSheet</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td style=" border-width:3px; border-style

utset;border-color:#f0f0f0; ">A</td><td style=" border-width:3px; border-style

utset;border-color:#f0f0f0; ">B</td><td style=" border-width:3px; border-style

utset;border-color:#f0f0f0; ">C</td><td style=" border-width:3px; border-style

utset;border-color:#f0f0f0; ">D</td><td style=" border-width:3px; border-style

utset;border-color:#f0f0f0; ">E</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >1</td><td >E</td><td >Y</td><td >Z</td><td >C</td><td >V</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >2</td><td style="text-align:right; ">78</td><td style="text-align:right; ">99</td><td style="text-align:right; ">17</td><td style="text-align:right; ">30</td><td style="text-align:right; ">13</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >3</td><td style="text-align:right; ">50</td><td style="text-align:right; ">89</td><td style="text-align:right; ">60</td><td style="text-align:right; ">12</td><td style="text-align:right; ">87</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >4</td><td style="text-align:right; ">62</td><td style="text-align:right; ">87</td><td style="text-align:right; ">14</td><td >EUROPE</td><td >MOVE</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >5</td><td style="text-align:right; ">19</td><td style="text-align:right; ">58</td><td style="text-align:right; ">27</td><td style="text-align:right; ">44</td><td style="text-align:right; ">92</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >6</td><td style="text-align:right; ">97</td><td style="text-align:right; ">16</td><td style="text-align:right; ">26</td><td style="text-align:right; ">94</td><td style="text-align:right; ">58</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >7</td><td style="text-align:right; ">47</td><td style="text-align:right; ">51</td><td style="text-align:right; ">22</td><td style="text-align:right; ">11</td><td style="text-align:right; ">73</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >8</td><td style="text-align:right; ">11</td><td style="text-align:right; ">68</td><td style="text-align:right; ">53</td><td style="text-align:right; ">76</td><td style="text-align:right; ">4</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >9</td><td style="text-align:right; ">61</td><td style="text-align:right; ">71</td><td style="text-align:right; ">30</td><td style="text-align:right; ">23</td><td >MOVE</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >10</td><td style="text-align:right; ">85</td><td style="text-align:right; ">79</td><td style="text-align:right; ">39</td><td style="text-align:right; ">18</td><td style="text-align:right; ">34</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >11</td><td style="text-align:right; ">24</td><td style="text-align:right; ">67</td><td style="text-align:right; ">79</td><td style="text-align:right; ">75</td><td style="text-align:right; ">51</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >12</td><td style="text-align:right; ">32</td><td style="text-align:right; ">97</td><td style="text-align:right; ">2</td><td >EUROPE</td><td >MOVE</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >13</td><td style="text-align:right; ">46</td><td style="text-align:right; ">55</td><td style="text-align:right; ">35</td><td style="text-align:right; ">4</td><td style="text-align:right; ">86</td></tr><tr style="height:18px ;" ><td style="border-width:3; border-style

utset;border-color:#f0f0f0; background-color:#cacaca; text-align:center; " >14</td><td style="text-align:right; ">61</td><td style="text-align:right; ">2</td><td style="text-align:right; ">39</td><td style="text-align:right; ">67</td><td style="text-align:right; ">30</td></tr></table> <br />Excel tables to the web - Excel Jeanie Html 4

Archive sheet initially empty.

Code:

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

After

<b>MainDataSheet</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td style=" border-width:3px; border-style