HHelp With Modifying VBA

[menor59]

Hello Team..

Found this on the Web...I have the following but i would Like to Modify It...

Sub Copy_To_Another_Sheet_1()
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim NewSh As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Fill in the search Value
    MyArr = Range("D3").Text
    'You can also use more values in the Array
    'myArr = Array("@", "www")

    'Add new worksheet to your workbook to copy to
    'You can also use a existing sheet like this
    'Set NewSh = Sheets("Sheet2")
    Set NewSh = Worksheets.Add

    With ActiveSheet.Range("F3:K100")

        Rcount = 0

        For I = LBound(MyArr) To UBound(MyArr)

            'If you use LookIn:=xlValues it will also work with a
            'formula cell that evaluates to "@"
            'Note : I use xlPart in this example and not xlWhole
            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 1

                    Rng.Copy NewSh.Range("A" & Rcount)

                    ' Use this if you only want to copy the value
                    ' NewSh.Range("A" & Rcount).Value = Rng.Value

                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

What I would Like to do is From the Value Of D3 on the Active Sheet, Find The Value from the Database Sheet which could be anywhere On the Database Sheet In Column B multiple times..

If Data is Found On the DataSheet Column B populate the values from C:H where to the Activesheet Range F:K (no Need to Add a New worksheet...) Just populate to the Active Sheet

 

[menor59]

Hello all...Here is a Better way of what im trying to accomplish...

This is My Database that has lines B2:H2000

This is the Active Sheet i will tie the Code to a Macro Button as "Update"

The Last Picture is the ActiveSheet. I need to Grab Data from the Database sheet Based on the Active Sheet D3, then From the Database sheet Find the Value of D3 in Range B2:B2000 and Return the Values where it is found from C2:H2000.

D3 or the Sheet Name from the ActiveSheet can be used to search the Database for the Value. Which ever you perfer.

Thank you so much for your time!

 

[JGordon11]

Maybe like this:

Sub CopyToDatabase()
    Const cols = 6, strCopyTo = "Database"
    Dim city As String, origin As Range, r, db, c, i As Long, j As Long, k As Long
    Dim rw(1 To 1, 1 To cols)
    city = [d3] 'Note - these hard-coded range addresses will cause trouble if you insert rows or columns before them
    r = [f3:k2001]
    With Sheets(strCopyTo)
        db = .[b2:b2000]
        Set origin = .[c2]
    End With
    k = 0
    j = 1
    For Each c In db
        If c = city Then
            For i = 1 To cols
                rw(1, i) = r(j, i)
            Next i
            j = j + 1
            origin.Offset(k).Resize(, cols) = rw
        End If
        k = k + 1
    Next
End Sub

 

[My Aswer Is This]

Try this:
My sheet has a sheet named "DataBase"
And a sheet named "Alpha"
I do not like using Active Sheet
Modify sheet name to your liking:

Sub Check_For_Data()
'Modified  4/12/2022  12:59:59 PM  EDT
Application.ScreenUpdating = False
Dim ans As String
ans = Sheets("Alpha").Range("D3").Value
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("DataBase").Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = 3

For i = 1 To Lastrow
    If Sheets("DataBase").Cells(i, 2).Value = ans Then
        Sheets("DataBase").Cells(i, 3).Resize(, 6).Copy Sheets("Alpha").Cells(Lastrowa, 6)
        Lastrowa = Lastrowa + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[menor59]

GOod Morning Guys.

Found this....CHeck this out..

=FILTER(Database!$C$2:$H$2000,Database!$B$2:$B$2000=$D$3)

I just pasted this into F3 on every sheet..and voila!!