trfing data from master wks to another wks Closed

Question

Hi all...I would to get help from here as I trying to input my project data into my Master list. When we select won or lost under the status for project, the data will auto disappear and transfer to the Won list and Lost List. Anyone can advise me how to do?? Appreciate you all can help me.. thanks in advance for all the valuable input.. :)

vcoolio · Answer

Hello Kai,

I'm not sure if I have understood you correctly but the following code may be what you want:-

Sub TransferIt()
Application.ScreenUpdating = False
Dim lRow As Long
Sheets("Master").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row

For Each Cell In Range("H2:H" & lRow)
    If Cell = "Won" Then
    Cell.EntireRow.Copy Sheets("Won").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Cell.EntireRow.ClearContents
    ElseIf Cell = "Lost" Then
    Cell.EntireRow.Copy Sheets("Lost").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Cell.EntireRow.ClearContents
    
End If
Next Cell

MsgBox "Data transfer completed!", vbExclamation
Range("A:G").Sort key1:=Range("A:A"), order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True

End Sub

You can have a look at my test work book here:-

https://www.dropbox.com/s/negciuugs2zngli/Kai1404.xlsm?dl=0

Try it out and  let us know if it works for you.

Kind regards,
vcoolio.

kai1401 · Answer

Hi Vcoolio 

Thanks for the reply.. But it seems like i have some error under this portion.


Range("A:S").Sort key1:=Range("A:A"), order1:=xlAscending, Header:=xlYes

vcoolio · Answer

Hi Kai,

I have only guessed at how your work book is set out as there is not a lot of information in your original post. Could you please upload a sample of your work book but please be careful with sensitive data. You can upload using a file sharing site such as DropBox.

My test work book still works fine , even extending the range to ("A:S") so until I see a sample it is difficult to see what the problem is. Could you also please advise which error message is coming up.

In the meantime, comment out line 19 of the code by placing an apostrophe (') in front of it (this should make the font colour of the line change to green) and try the code without it.

Regards,
vcoolio.

kai · Answer

Hi Vcoolio

Sorry for the late reply. 

This is the link for my worksheet. 
https://www.dropbox.com/s/ugdsennsxk13ofu/Project%20Pipline%20-%20Copy.xlsx?dl=0

vcoolio · Answer

Hello Kai,

Try this amended code:-

Sub TransferIt()
Application.ScreenUpdating = False
Dim lRow As Long
Sheets("Pipeline").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row

For Each Cell In Range("Q4:Q" & lRow)
    If Cell = "WON" Then
    Cell.EntireRow.Copy Sheets("Won").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Cell.EntireRow.ClearContents
    ElseIf Cell = "LOST" Then
    Cell.EntireRow.Copy Sheets("Lost").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Cell.EntireRow.ClearContents
End If
Next Cell

MsgBox "Data transfer completed!", vbExclamation
Range("A3:Q" & lRow).Sort key1:=Range("I3:I" & lRow), order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True

End Sub

There were some discrepancies between the sheet tab names and the validation drop down contents. For example, you have WON, LOST etc. in upper case in the drop down but the sheet tab names have a capital and then lower case (Won, Lost). So the code did not reconcile between it and the sheet names. Also you don't have a sheet named "Master" but instead "Pipeline". The criteria (WON, LOST etc.) is in Column Q not Column H as per my guess.

The "sort" code now sorts on Column I, the estimated start month. It works ok now. However, you may prefer to sort on "Date" instead in Column A. This I will leave to you. Just change the reference in the code to "A3:A". The merged cells in the headings may cause a problem. If they do, unmerge them and re-format your headings without merging cells.

All the discrepancies have been accounted for in the above amended code, I think!

Kind regards,
vcoolio.

kai · Answer

Hi Vcoolio

Thanks so much for your advise. Somehow it does not allow me to save the coding in my excel file. And i need your advise as well, the worksheet seems like will left a blanket in between when the won/no bid and lost is move to another worksheet. And once i move to another worksheet, i cannot move back the Pipeline worksheet. Any solution to it? Thanks in advance and sorry for asking so many qn..

vcoolio · Answer

Hello Kai,

I just tried the code a number of times again in the test work book and your work book and all is working just fine. Could the problem actually be with your system?

Regards,
vcoolio.

kai · Answer

hello vcoolio

You mean there shouldn't b blank when trf to the won worksheet? and we can move back the won project to Pipeline worksheet?

Sorry to ask.. am i suppose to save in a new module ?

vcoolio · Answer

Hello Kai,

Yes, place the code in a new module. On the "Pipeline" sheet, create a button and assign the macro to it.

I have just tried the code again in your work book. There are no blanks and all entries go to the correct sheet, row by row. The code takes you back to the "Pipeline" sheet. It may be simplest to purge the worksheets and start again afresh (or create a new work book from scratch).

I'll be away for a few days but post back and let us know how it goes.
Regards,
vcoolio.

kai · Answer

Hi Vcoolio

Thanks. I try again as my worksheet seems to be having alot of problem.

kai1401 · Answer

Hi Vcoolio

I trying to use this code but it seems like giving me error. it keep showing me ActiveSheet.AutoFilter.ApplyFilter error. 

XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Private Sub Worksheet_Change(ByVal Target As Range)

    ActiveSheet.AutoFilter.ApplyFilter

End Sub
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

Private Sub Worksheet_Calculate()
     
    If Me.FilterMode = True Then
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
         
        With ActiveWorkbook
            .CustomViews.Add ViewName:="Mine", RowColSettings:=True
            Me.AutoFilterMode = False
            .CustomViews("Mine").Show
            .CustomViews("Mine").Delete
        End With
         
         
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
     
End Sub

TrowaD · Answer

Hi Kai,

Vcoolio has asked me to see if I can help you out while he is away.

Change
ActiveSheet.AutoFilter.ApplyFilter
into
ActiveSheet.AutoFilter

And try again.

Let us know if further questions arise.

Best regards,
Trowa

vcoolio · Answer

Hello Kai,

I'm back! But not for long as I will be leaving tomorrow for another stint in the wilderness.

Just going back to the original code I gave you, here is an amended version for you:-

Sub TransferIt()
   Application.ScreenUpdating = False
Dim lRow As Long
     Sheets("Pipeline").Select
     lRow = Range("A" & Rows.Count).End(xlUp).Row

For Each Cell In Range("Q4:Q" & lRow)
    If Cell = "WON" Then
    Cell.EntireRow.Copy Sheets("Won").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    ElseIf Cell = "LOST" Then
    Cell.EntireRow.Copy Sheets("Lost").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If

Next Cell

MsgBox "Data transfer completed!", vbExclamation
  Sheets("Won").Range("A3:S" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
  Sheets("Lost").Range("A3:S" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
  Sheets("Pipeline").Range("A3:Q" & lRow).Sort key1:=Range("C3:C" & lRow), order1:=xlAscending, Header:=xlYes
  Application.ScreenUpdating = True

End Sub


This code should do what you want based on the criteria "WON" or "LOST".
Once you select "WON" from the drop down in Column Q, all rows of data with this criteria will be transferred to the "Won" sheet. The same will happen with the "LOST" criteria.

All data in the "Pipeline" sheet will remain intact with no blank rows anywhere.

You can have a look at the test work book here:-

https://www.dropbox.com/s/8igkwhgj9qvtsws/Kai1404%282%29.xlsm?dl=0

to see how it works.

Add some more fictitious data like I did, then click on the "Transfer Data" button to transfer the required data to the relevant sheet.

There should be no duplicate entries in the "Won' or "Lost" sheets with this code.

@ Trowa:-

Thanks for keeping an eye on the shop while I was away. Much appreciated.

Cheers Gentlemen,
vcoolio.

Trfing data from master wks to another wks

13 responses

Subscribe To Our Newsletter!