macro copy/paste lists data from multiple sheets to one comparison sheet

**johnnieboi89** · 06-29-2011, 09:39 AM

I have a workbook that uses multiple sheets. I am trying to make one sheet that compares the different data.
On the sheet that compares the different data I was wanting to create a macro that once you click a field in the combo box the relative data pops up on the screen. I also want the macro to auto matically line the data up side by dside
I have been successful with this macro (with the help of this forum) to pull data from a single page. However, I need this macro to work for all of the pages in my workbook.

Here is the macro that I used to make the combo box work for pulling data from a single work sheet


Sub DropDown2_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    Set rngCodes = Sheets("Sheet1").Range("B1", Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft))
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then Exit Sub
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

And here is the code that didnt work when pulling from multiple sheets.

  Sub DropDown2_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    Set rngCodes = Sheets("Total Annual").Range("B1", Sheets("Total Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("LH Annual").Range("B1", Sheets("LH Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("PC Annual").Range("B1", Sheets("PC Annual").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Reinsurance").Range("B1", Sheets("Reinsurance").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Quarterly AM Best").Range("B1", Sheets("Quarterly AM Best").Cells(1, Columns.Count).End(xlToLeft))
    Set rngCodes = Sheets("Annual AM Best").Range("B1", Sheets("Annual AM Best").Cells(1, Columns.Count).End(xlToLeft))
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then Exit Sub
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

I am also attaching the document that I am trying to run the macro in.

here is a link to my previous thread about the same issue:

http://www.excelforum.com/excel-prog...o-another.html

**tigeravatar** · 06-29-2011, 11:54 AM

johnnieboi89,

I already posted this solution in the other thread, but here it is again. All of the items can be found in one of the following 2 worksheets: 'Quarterly AM Best' and 'Annual AM Best' so there is no need to include the other sheets. Here's the updated code:

Sub DropDown1_Change()
    
    Const FirstCell As String = "B1"
    
    Dim rngDest As Range: Set rngDest = ActiveSheet.Range(FirstCell)
    Dim ddn_Code As DropDown
    Dim rngCodes As Range
    Dim ChosenCode As String
    Dim rngFound As Range
    
    Dim ws1 As Worksheet: Set ws1 = Sheets("Quarterly AM Best")
    Dim ws2 As Worksheet: Set ws2 = Sheets("Annual AM Best")
    
    Set ddn_Code = ActiveSheet.DropDowns(Application.Caller)
    ChosenCode = ddn_Code.List(ddn_Code.Value)
    
    Set rngCodes = ws1.Range("C1", ws1.Cells(1, Columns.Count).End(xlToLeft))
    Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    If rngFound Is Nothing Then
        Set rngCodes = ws2.Range("C1", ws2.Cells(1, Columns.Count).End(xlToLeft))
        Set rngFound = rngCodes.Find(LCase(Trim(ChosenCode)))
    End If
    Set rngFound = rngFound.Offset(1, 0).Resize(rngFound.CurrentRegion.Rows.Count - 1, 1).SpecialCells(xlCellTypeConstants)
    
    If rngDest.Value = vbNullString Then
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    Else
        Set rngDest = ActiveSheet.Cells(rngDest.Row, Columns.Count).End(xlToLeft).Offset(0, 1)
        rngDest.Resize(rngFound.Rows.Count, 1).Value = rngFound.Value
    End If
    
End Sub

Hope that helps,
~tigeravatar

**johnnieboi89** · 06-29-2011, 03:10 PM

There is also information onLH Annual, Pc, Annual, Total annual, and reinsurance. I cant get the code to work for those pages. Nor can I get the fields that have more than 5 rows of data to show all of the data in the list.

Jhnnieboi89