Criteria dependent data transfer.Closed

Question

Good Morning,
I would really appreciate some assistance with regards to a workbook I am creating in Excel 2010 to track equipment movements.
I have created several spreadsheets within a workbook titled as follows - Equipment Register; Available Equipment & Quarantined Equipment. What I would like to do is to be able to automatically transfer the data for each piece of equipment listed in the 1st sheet dependant on its status (ie if status is stock move into the Available Equipment Sheet and if quarantined move to the quarantined sheet).
Any assistance would be greatly appreciated.
Thank you.

vcoolio · Answer

Hello SFRIAR616,

You say that you have several sheets within your workbook. Could you name them all for us please and also advise which status you use for each sheet.

Thank you.

Cheerio,
vcoolio.

vcoolio · Answer

Hello SFriar616,

Based on what you have described, try the following code in a copy of your work book:-

Option Explicit

Sub MoveStuff()

Dim ar As Variant, i As Integer, ws As Worksheet

ar = [{"Available Equipment","Quarantined Equipment(C)","Quarantined Equipment(R)";"Stock","Calibration","Repair"}]

Application.ScreenUpdating = False

Set ws = Sheet1

For i = 1 To UBound(ar, 2)
           Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents
                With ws.Range("H1", ws.Range("H" & ws.Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(2, i)
                    ws.Range("A2", ws.Range("G" & ws.Rows.Count).End(xlUp)).Copy
                     Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
                     .AutoFilter
                    Sheets(ar(1, i)).Columns.AutoFit
            End With
    Next i
   
ws.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

I've created a little sample for you to play with at the following link:-

http://ge.tt/2GGd2Zm2

You'll notice that I have created an extra sheet named "Quarantined Equipment (R)" which is where the data for equipment designated for repair will be transferred. The data for equipment designated for calibration will be transferred to the "Quarantined Equipment (C)" sheet. This method will mean less iterations for the code to execute which, in turn, will make for a more seamless transfer of data process.

Click on the "RUN" button to see it work.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello again SFriar616,

I noticed in your post #2 that you mentioned that the data in the Equipment Register is in table format. I'm not sure if you mean that it is an actual table or a normal data set.

Just in case, following is the code adjusted to allow for an actual table format:-


Option Explicit

Sub MoveStuff()

Dim ar As Variant, i As Integer, ws As Worksheet, lr As Long

ar = [{"Available Equipment","Quarantined Equipment(C)","Quarantined Equipment(R)";"Stock","Calibration","Repair"}]

Application.ScreenUpdating = False

Set ws = Sheet1
ws.ListObjects("Table1").Unlist

For i = 1 To UBound(ar, 2)
           Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents
                With ws.Range("H1", ws.Range("H" & ws.Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(2, i)
                    ws.Range("A2", ws.Range("G" & ws.Rows.Count).End(xlUp)).Copy
                     Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
                     .AutoFilter
                    Sheets(ar(1, i)).Columns.AutoFit
            End With
    Next i
   
ws.Select
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.ListObjects.Add(xlSrcRange, Range("A1:L" & lr), , xlYes).Name = "Table1"

Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub


Following is the link to the updated file sample:-

http://ge.tt/99VR8Zm2

The code refers to the table as "Table1". If you have a different name for it, then change "Table1" in lines 13 and 30 to whatever your table name is.

Cheerio,
vcoolio.

vcoolio · Answer

Hello SFriar616,

Now having seen your file, I've made a slight adjustment to the code as follows:-

Option Explicit

Sub MoveStuff()

Dim ar As Variant, i As Integer, ws As Worksheet, lr As Long

ar = [{"AVAILABLE EQUIPMENT","EQUIPMENT FOR CALIBRATION","EQUIPMENT FOR REPAIR","PRE OP CHECKS DUE";"STOCK","CALIBRATION","REPAIR","PRE OP CHECK"}]

Application.ScreenUpdating = False

Set ws = Sheet1
lr = ws.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To UBound(ar, 2)
           Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents
                With ws.Range("H1", ws.Range("H" & ws.Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(2, i)
                    Union(ws.Range("A2:G" & lr), ws.Range("I2:I" & lr)).Copy
                     Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
                    Sheets(ar(1, i)).Columns.AutoFit
                    .AutoFilter
            End With
    Next i
   
ws.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "All done!", vbExclamation

End Sub

Following is the link to your file with the code implemented:-

http://ge.tt/7yCsram2

In the sample file that you supplied, you had placed the code in the sheet module. The sheet module is for event type codes only. You'll note that I have placed the code in a standard module and assigned it to the button "GO". Please remove the code from the sheet module in your actual work book, place it in a standard module and assign it to a button, as per the link above.

You may also note that I have included the "Location" column in the destination sheets as I thought that it just may be handy to be able to immediately sight where the equipment is located.

Test the code in a copy of your work book first.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello SFriar616,

You're welcome. I'm glad that I was able to help.

Cheerio,
vcoolio.

Criteria dependent data transfer.

5 responses

Similar discussions

Subscribe To Our Newsletter!