VBA Excel：宏，该宏在一行中搜索特定单元格中的某个变量值，然后将值复制并粘贴到此列中

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

Answer 1

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