需要根据第一库仑值将数据范围从一个Excel工作表复制到另一个工作表

Question

I have excel table (sample example below with header) without headers with almost 8 thousand rows in it. I need to copy values of column B,C,D to another sheet if the value in column A matches. Also the problem is column A does not have value in each row. It is populated only when it will have a value which is different from the previous row value.

Consider sample table below:

    ProdID    Name     Prop       Reveiwer  
    1        abcName  abcProp     abcRev  
             qweName  qweProp     qweRev  
             asdName  asdProp     asdRev  
    2        jhkName  jhkProp     jhkRev  
             mnbName  mnbProp     mnbRev  
    1        eName    eProp       eRev  
             aName    aProp       aRev  

Expected output when we choose 1 is :

    ProdID  Name     Prop     Reveiwer  
    1      abcName  abcProp   abcRev  
           qweName  qweProp   qweRev  
           asdName  asdProp   asdRev  
           eName    eProp     eRev  
           aName    aProp     aRev 

I have tried several logic to achieve above output using VBA but none of them worked.

Can anyone help me with VBA code which can get the expected output.Also let me know if this can be achieved with simple method other than VBA.

Answer 1

The fastest way is to populate the first column. You should have a cycle on a column you know it is fully populated (ie column 2) store the prodID in a variable and use it each time prodID is = "" for example:

i=start_row
While Range("B" & i) <> ""
 if Range("A" & i) <> "" then
  prod_id=Range("A" & i)
 else
  Range("A" & i)=prod_id
 end if
 i=i+1
wend

Answer 2

Search and List Cell Values Based On A Common ID

I've recreated your data in a spreadsheet named Sheet1

On Sheet2 I have a blank sheet with only the headers

When I click the button on Sheet1 , I'll be prompted with an InputBox

In this example, I'll search for Prod ID value of 1. The following is the result on Sheet2

I can repeat this as many times as I want, and the result page will automatically clear itself of old search values and only list new searches.

---

The Code

Place the following code in a module. FindAndShow is the macro you want to assign to the button shape on the first page, if you wish to set yourself up the same way I have it.

Sub FindAndShow()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim wsResult As Worksheet: Set wsResult = ThisWorkbook.Sheets(2)
    Dim prodID As String, prodRng As Range
    Dim myRowOffset As Long, mySearch As String, nextRow As Long

    'First is clearing old search items
    wsResult.Range("A2", "D" & wsResult.Cells(wsResult.Rows.Count, "B").End(xlDown).Row).Clear

    'Next we find the next blank row to start placing our results. As I have it, this will
    'always be 2 because we're clearing old data. I've left it dynamic to make modifying the
    'code easier.
    nextRow = wsResult.Range("B2", wsResult.Cells(wsResult.Rows.Count, "B").End(xlUp)).Row + 1

    'Here we take our input from the user.
    'You can change the prompt and title to fit your needs.
    prodID = InputBox("Which Production ID would you like to find?", "Production ID Search")
    Set prodRng = ws.Range("A:A").Find(What:=prodID, LookIn:=xlValues, LookAt:=xlWhole)

    'This is the loop that finds search items, and pastes them to the results page.
    'Normally having range.value = range.value would be quickest, but since we're dealing with
    'thousands of cells that are in sizable groups, the copy method will be most ideal.
    If Not prodRng Is Nothing Then
    wsResult.Range("A" & nextRow).Value = prodID
        firstResult = prodRng.Address
        Do
            myRowOffset = FindRowOffset(prodRng)
            ws.Range(prodRng.Offset(0, 1), prodRng.Offset(myRowOffset, 3)).Copy _
                wsResult.Range("B" & nextRow)
            Set prodRng = ws.Range("A:A").FindNext(prodRng)
            nextRow = nextRow + myRowOffset + 1
        Loop While Not prodRng Is Nothing And prodRng.Address <> firstResult
    End If
End Sub

Function FindRowOffset(myRange As Range) As Long
    'This functions only purpose is to see how far each search block goes.
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim i As Long: i = 1

    Do While myRange.Offset(i).Value = "" And myRange.Offset(i, 1) <> ""
        i = i + 1
    Loop
    FindRowOffset = i - 1
End Function