Page 1 of 2 12 LastLast
Results 1 to 15 of 18
  1. #1
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Macro to pull out data of multiple items selected from dropdown to seperate worksheet

    Hello Everyone,

    I need some help in macro from anybody in the group please.

    I have a master tracker contains thousands of rows with one column as Person Name. In the same sheet, I have a drop down of those Person names. I already got the macro to select multiple names from drop down list. Now if I am selecting multiple names from drop down, it should throw out all the data of those selected people in different worksheet in separate tabs. I am in need of macro to do the same.

    Hope I could able to explain it clearly. Anyhow, I am attaching the excel sheet with some dummy data in it.

    Thanks in Advance.

    Best Regards,
    Abhishek
    Attached Files Attached Files

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Abhishek,

    Here's some code to show you how to handle this stuation:
    Code:
    Option Explicit
    
    Sub ProcessData()
    
       Dim vSelected    As Variant
       Dim lCntr        As Long
       Dim lSelectedCnt As Long
       Dim lCurRow      As Long
       Dim lDestCurRow  As Long
       Dim zCurName     As String
       Dim shtDest      As Worksheet
       
       '*** Setup ***
       vSelected = Split([B2].Value, ",")
       lSelectedCnt = UBound(vSelected)
       Set shtDest = ActiveWorkbook.Sheets("DestSheet")  '*** Sheet to copy to ***
       lDestCurRow = shtDest.Cells(Rows.Count, 1).End(xlUp).Row() + 1 'Row to copy to
         
       
       For lCntr = 0 To lSelectedCnt
       
          zCurName = Trim(vSelected(lCntr)) 'Suppress leading/trailing spaces
          lCurRow = 5
          
          Do
            If (Cells(lCurRow, "E").Value = zCurName) Then
            
              '**** Your Process goes here ***
              
              '**** Sample Process     ****
                Range(Cells(lCurRow, 1), Cells(lCurRow, 6)).Copy shtDest.Cells(lDestCurRow, 1)
                lDestCurRow = lDestCurRow + 1  '*** Move to Next Row ***
              '**** End Sample Process ****
              
            End If
            lCurRow = lCurRow + 1  'Increment Row Counter
          Loop Until (Cells(lCurRow, 1).Value = "")
       
       Next lCntr
     
    
    End Sub 'ProcessData
    Here's the sample output using your test data w/A,C selected.

    ashcopy.PNG

    Here's the test file: Abhishek Dummy Data-RGV1.xlsm

    Post back if you have more questions.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thank you very much for the macro.

    Its working but I need data for A & C in different worksheet in separate tabs (one tab for data A & other for data B). Could it be possible. Thank you.

    Best Regards,
    Abhishek

  4. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Abhishek,

    Ok, here are the mods.

    1. The output WORKBOOK MUST ALREADY EXIST! Note: currently set to G:\Test\AbhishekDataOut.xlsx which you'll most likely want to change! I may get some time later to fix this but for now...
    2. Sheets will be created in the output if they don't already exist and the header data will be copied.
    3. Probably need some more error checking...maybe later or someone else may chime in if you can't figure it out.


    ashcopy.PNG

    Code:
    Option Explicit
    
    Function SheetExists(xlWkBk As Workbook, xlWkShtNm As String) As Boolean
    
    '*** Returns True if the Sheet Name already exists in the workbook ***
    '*** Returns False if it is safe to create a sheet by that name    ***
       SheetExists = False
       On Error GoTo NoSuchSheet
       If Len(xlWkBk.Sheets(xlWkShtNm).Name) > 0 Then SheetExists = True
    
    NoSuchSheet:
    
    End Function
    
    Sub ProcessData()
    
       Dim vSelected    As Variant
       Dim lCntr        As Long
       Dim lSelectedCnt As Long
       Dim lCurRow      As Long
       Dim lDestCurRow  As Long
       Dim zCurName     As String
       Dim shtDest      As Worksheet
       Dim shtMain      As Worksheet
       Dim wkbDest      As Workbook
       
       '*** Setup ***
       vSelected = Split([B2].Value, ",")
       lSelectedCnt = UBound(vSelected)
       Set shtMain = ActiveWorkbook.Sheets("MainData") '*** Change to match your workbook ***
       Set wkbDest = Workbooks.Open("G:\Test\AbhishekDataOut.xlsx") '*** Must Already Exist ***
       
       For lCntr = 0 To lSelectedCnt
       
          zCurName = Trim(vSelected(lCntr)) 'Suppress leading/trailing spaces
          
          If (Not (SheetExists(wkbDest, zCurName))) Then
            '*** Destination sheet does not exist create it! ***
            Set shtDest = wkbDest.Sheets.Add(After:=Sheets(Sheets.Count))
            shtDest.Name = zCurName
            shtMain.Activate                            '*** Return to Main Sheet     ***
            Range("$A$4:$F$4").Copy shtDest.Cells(1, 1)  '*** Copy Header to new sheet ***
          End If '(SheetExists...
          
          Set shtDest = wkbDest.Sheets(zCurName)  '*** Sheet to copy to ***
          lDestCurRow = shtDest.Cells(Rows.Count, 1).End(xlUp).Row() + 1 'Row to copy to
    
          lCurRow = 5
          
          Do
            If (Cells(lCurRow, "E").Value = zCurName) Then
            
              '**** Your Process goes here ***
              
              '**** Sample Process     ****
                Range(Cells(lCurRow, 1), Cells(lCurRow, 6)).Copy shtDest.Cells(lDestCurRow, 1)
                lDestCurRow = lDestCurRow + 1  '*** Move to Next Row ***
              '**** End Sample Process ****
              
            End If
            lCurRow = lCurRow + 1  'Increment Row Counter
          Loop Until (Cells(lCurRow, 1).Value = "")
       
       Next lCntr
     
    
    End Sub 'ProcessData
    Here's the test file: Abhishek Dummy Data-RGV2.xlsm

    HTH
    Last edited by RetiredGeek; 2016-06-22 at 16:19.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. #5
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Many Thanks RetiredGreek. Its working fine.

    Really appreciable if it could be possible to export the data in the new sheet instead of already existing workbook and give the users "Save As" option.
    Actually I need to roll the master tracker to lots of people & based on requirement they can select the names from drop down & save it in their desktop.

    Best Regards,
    Abhishek

  6. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Change This: Set wkbDest = Workbooks.Open("G:\Test\AbhishekDataOut.xlsx")

    To This: Set wkbDest = Workbooks.Add

    When the user exits they will automatically be prompted to save the new workbook if they haven't already done it.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  7. #7
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thank you very much RetiredGeek. Its absolutely working fine and solving the purpose as well.

    Just thinking to delete the Sheet1 in the newly created workbook, looks little awkward. I believe the below code would work and where should I insert this line. Thank You.

    wkbDest.Sheets("Sheet1").Delete

    Best Regards,
    Abhishek

  8. #8
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Quote Originally Posted by abhi_jain80 View Post
    Thank you very much RetiredGeek. Its absolutely working fine and solving the purpose as well.

    Just thinking to delete the Sheet1 in the newly created workbook, looks little awkward. I believe the below code would work and where should I insert this line. Thank You.

    wkbDest.Sheets("Sheet1").Delete

    Best Regards,
    Abhishek
    That will work just fine just make sure you place it at the end of the code outside the loop just above the End Sub.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  9. #9
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi RetiredGreek,

    Thanks for your inputs. I placed it at the end of the code. It's throwing a warning message as under mentioned;

    You can't undo deleting sheets, and you might be removing some data. if you don't need it, Click Delete.

    Could it be possible I won't get this warning message & "sheet1" would get deleted. I know I'm troubling you again but as I'm novice in macros. Couldn't be able to do much. Hence it is...

    Best Regards,
    Abhishek

  10. #10
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Abhishek,

    Surround the delete command as follows:

    Code:
       Application.DisplayAlerts = False
       wkbDest.Sheets("Sheet1").Delete
       Application.DisplayAlerts = True
    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  11. #11
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Many Thanks RetiredGreek. It's working absolutely fine.

    Best Regards,
    Abhishek

  12. #12
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi RetiredGreek,

    Its absolutely working fine when there in only sheet "MainData". But I am having 2 more tabs in the same worksheet, because of which it is throwing error. Please help in resolving the issue. Sorry I forget to mention this point earlier.

    Attaching the same for your reference please.

    Best Regards,
    Abhishek
    Attached Files Attached Files

  13. #13
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Abhishek,

    What error are you getting? What did you do to get the error?
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  14. #14
    Lounger
    Join Date
    Jun 2016
    Posts
    41
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hi RetiredGreek,

    I am getting the error as "Method 'Add' of object 'Sheets' failed". Debug at code line

    Set shtDest = wkbDest.Sheets.Add(After:=Sheets(Sheets.Count))

    I have added two more tabs in the same worksheet lets say abc and def. After that error started appearing. Please help in resolving the issue.

    Best Regards,
    Abhishek

  15. #15
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,433
    Thanks
    371
    Thanked 1,456 Times in 1,325 Posts
    Abhishek,

    Change:
    Code:
    Set shtDest = wkbDest.Sheets.Add(After:=Sheets(Sheets.Count))
    To:
    Code:
    Set shtDest = wkbDest.Sheets.Add(After:=wkbDest.Sheets(wkbDest.Sheets.Count))
    
    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •