VBA Excel : Macro that searches a row for a certain variable value from specific cell and then copy&pastes value to this column

Question

I have done some VBA in the past but just cannot find a solution for this one.

I am looking for a macro which searches cells C4 to Z4 (one infinite long row starting from C4) for a value (number) from cell B4 which changes weekly. If a match is found then copy&pastes the values of cells B5 to B100 (one infinite long column starting from B5) into the correct column C to Z (from C5 etc., downwards).

With correct column I mean the column where the macro finds the match between B4 and C4 to Z4. C4 to Z4 are non-identical.

I searched long and hard and the nearest I could find is this: Macro that looks for a value in a cell & then paste a range in the column of that cell. EXCEL 2007

However it does not work for me. The solution in that thread says that the matching cell values should be in a date format. I recontructed all of this, but even with dates instead of numbers it does not work. The macro always gives the message according to the VBA line

MsgBox "Date Column for " & CStr([B2].Value) & " Not Found"

So it does not find any matches for me, even I run it with identical dates in the matching cells. (I changed of course this macro to my cell locations)

This forum is my final try :)

I have following code which does not work:

Private Sub CommandButton2_Click()

Dim ws As Worksheet
Dim rSrc As Range
Dim rDst As Range
Dim cl As Range
Dim dat As Variant

Set ws = ActiveSheet

' Get the Source range
Set rSrc = ws.Range([B5], ws.Columns(2).Cells(ws.Rows.Count, 1).End(xlUp))
dat = rSrc

' Find the Destination column and copy data
Set rDst = ws.Range([D4], ws.Rows(1).Cells(1, ws.Columns.Count).End(xlToLeft))
Set cl = rDst.Find(What:=[B4], _
  After:=rDst.Cells(1, 1), _
  LookIn:=xlValues, _
  LookAt:=xlWhole, _
  SearchOrder:=xlByRows, _
  SearchDirection:=xlNext)
If cl Is Nothing Then
    MsgBox "Column for " & CStr([B4].Value) & " Not Found"
Else
    Set rDst = cl.Offset(1, 0).Resize(UBound(dat, 1), 1)
    rDst = dat
End If

End Sub

Thank you.

Regards

can you post the code that doesn't seem to work? Also, does your data have any gaps in the C4 to Z4 range? — SRT HellKitty
Welcome to Stack Overflow! You will find that you will have a better experience if you take moment to take the Stack Overflow tour. You can also read about asking a good question. If you follow the norms of the Stack Overflow community and approach it with an attitude of helping others too, it will serve you well. — StoneGiant
Thank you @SRT HellKitty. It does not have a gap between C4 and Z4. — Michael Kohl

Harassed Dad Harassed Dad · Accepted Answer · 2018-12-05T16:46:01

Sub FindandCopy
Dim what as range
dim where as range
dim found as range
set what = range("b4")  'what we're looking for
set where = range("c4")  'start of search range
do
if where = what then 
    set found = where  'that's where we found it
else
 set where = where.offset(0,1) 'otherwise keep looking
end if
loop until where = ""   'stop if blank
if found = "" then  'we fell off the end
      msgbox what & " not found "
else
      range(range("b5"),range("b5").end(xldown)).copy 
      found.offset(1,0).pastespecial xlpastevalues
end if
end sub

VBA Excel : Macro that searches a row for a certain variable value from specific cell and then copy&pastes value to this column

1 Answers