How can i look for a not specific value from one worksheet in another worksheet in Excel?

user_16706411 0
Viewed 58

i am trying to program a macro that i can use on a random value in one worksheet, and the macro is supposed to look for it in another worksheet, go 11 cells to the left and copy the Value in that cell back to the first worksheet, next to the random value.

my macro so far:

Sub Makro3()

    Selection.Copy
    
    Sheets("Messgeräte").Select
    
    
    Cells.Find(What:=***thats where i dont know what to put***, After:=ActiveCell, LookIn:= _
        xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
        , MatchCase:=False, SearchFormat:=False).Activate
        
    ActiveCell.Offset(0, -11).Select
    
    Application.CutCopyMode = False
    
    Selection.Copy
    
    Sheets("Lagermedien").Select
    
    ActiveCell.Offset(0, 1).Select
    
    ActiveSheet.Paste
    
End Sub

please dont judge, i am new to this :)

the problem for me is that it is always new values and new cells. Otherwise i could just record a macro.

In the best case scenario this would work with more than one Value, means: the program looks for the random Value in the second worksheet and finds a couple of different cells that all have that very same Value and copies them to the first worksheet.

vba excel
2 Answers

This will handle multiple matches:

Sub Makro3()

    Dim f As Range, c As Range, allMatches As Collection, i As Long
    
    Set c = Selection.Cells(1) 'only want one cell, so take first if >1 selected
    
    Set allMatches = FindAll(Sheets("Messgeräte").Cells, c.Value) 'find all matches
    i = 0
    For Each f In allMatches 'loop over any matched cells
        i = i + 1
        f.offset(0, 11).Copy c.Offset(0, i)
    Next f
End Sub

'Find all (partial) matches in a range, and return them as a collection of cells
Public Function FindAll(rng As Range, val As String) As Collection
    Dim rv As New Collection, f As Range
    Dim addr As String

    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
                     LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                     SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()

    Do Until f Is Nothing
        rv.Add f
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop
    Set FindAll = rv
End Function
user_4788840

Multi VBA Lookup (Find)

  • This will loop through the cells of column A (dlCol) in Destination to find each 'partial' (xlPart) occurrence of the cell value, in column M (slCol) of Source to write the corresponding values of column A (svCol) in Source to columns (.Offset(, cOffset)) of the corresponding row in Destination, starting with column B (dvCol).
  • Carefully adjust the values in the constants section. Note that there is no Undo.
Option Explicit

Sub MultiLookupFind()

    ' Source
    Const sName As String = "Messgeräte" ' Worksheet Name
    Const sfRow As Long = 2 ' First Row
    Const slCol As String = "M" ' Lookup Column
    Const svCol As String = "A" ' Value Column
    ' Destination
    Const dName As String = "Lagermedien" ' Worksheet Name
    Const dfRow As Long = 2 ' First Row
    Const dlCol As String = "A" ' Lookup Column
    Const dvCol As String = "B" ' Value Column
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim slrg As Range: Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
    If dlRow < dfRow Then Exit Sub ' no data
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)

    ' Loop
    Dim dCell As Range
    Dim sCell As Range
    Dim dString As String
    Dim cOffset As Long
    Dim FirstAddress As String
    For Each dCell In dlrg.Cells
        Set sCell = Nothing
        cOffset = 0
        dString = CStr(dCell.Value)
        Set sCell = slrg.Find(dString, slrg.Cells(srCount), xlFormulas, xlPart)
        If Not sCell Is Nothing Then
            FirstAddress = sCell.Address
            Do
                dCell.EntireRow.Columns(dvCol).Offset(, cOffset).Value _
                    = sCell.EntireRow.Columns(svCol).Value
                Set sCell = slrg.FindNext(sCell)
                cOffset = cOffset + 1
            Loop Until sCell.Address = FirstAddress
        End If
    Next dCell

End Sub
user_98140690
Related