Match Value in Range and Then Paste

[K]

Hi all, I am looking for macro which should do something (see below)

EXAMPLE :

Sub test ()
set OldWbk = Workbooks("Main.xlsm")
Workbooks.Open Filename:= "C:\My Document\" & OldWbk.Range("A1").Value
& ".xlsm"
ActiveWorkbook.Range("I2:J15").Copy
OldWbk.Select
If (any cell.value) in OldWbk.Range("D1:F1") =
OldWbk.Range("A1").Value Then
Select.Offset.(of that cell).Paste
End Sub

Above is just rough example that what I want macro to do. Basically I
want macro to open workbook of which name is in Range("A1") and then
copy data from that workbook and then come back to old workbook and
look in each cell of Range("D1:F1") and if any cell have same value to
Range("A1") then Paste data one cell below of that cell. Please can
any friend help me on this

 

[Joel]

Try this

Sub test()
Set OldWbk = Workbooks("Main.xlsm")
Set newbk = Workbooks.Open(Filename:= _
"C:\My Document\" & OldWbk.Range("A1").Value & ".xlsm")

For Each cell In newbk.Range("I2:I15")

Data = cell.Offset(0, 1)
With OldWbk
Set c = .Range("D1:F1").Find(what:=cell, _
LookIn:=xlValues, loookat:=xlWhole)
If c Is Nothing Then
MsgBox ("could not find : " & cell)
Else
LastRow = .Cells(Rows.Count, c.Column).End(xlUp).Row
NewRow = LastRow + 1
.Cells(NewRow, c.Column) = Data
End If
End With
Next cell
End Sub

 

[K]

Try this

Sub test()
Set OldWbk = Workbooks("Main.xlsm")
Set newbk = Workbooks.Open(Filename:= _
    "C:\My Document\" & OldWbk.Range("A1").Value & ".xlsm")

For Each cell In newbk.Range("I2:I15")

   Data = cell.Offset(0, 1)
   With OldWbk
      Set c = .Range("D1:F1").Find(what:=cell, _
         LookIn:=xlValues, loookat:=xlWhole)
      If c Is Nothing Then
         MsgBox ("could not find : " & cell)
      Else
         LastRow = .Cells(Rows.Count, c.Column).End(xlUp).Row
         NewRow = LastRow + 1
         .Cells(NewRow, c.Column) = Data
      End If
   End With
Next cell
End Sub








- Show quoted text -

Hi joel, Thanks for replying. The actual macro on which I am working
with is (see below)

Sub import()

Set src = Workbooks("Book5.xlsm").Sheets("Sheet1")
If src.Range("D20").Value <> "" Then
Workbooks.Open Filename:= _
C:\My Document\2008-2009\TIMESHEETS\ & src.Range("D20") & ".xlsm"
Set des = Workbooks(src.Range("D20").Value & ".xlsm").Sheets("TIME
SHEET")
Set des2 = Workbooks(src.Range("D20").Value & ".xlsm")
des.Unprotect Password:="TIMESHEET"
For I = 4 To 43
src.Range("H" & I) = Format(des.Range("I" & ((3 * I) - 2)), "0%")
src.Range("I" & I) = Format(des.Range("J" & ((3 * I) - 2)), "0%")
Next I
des.Range("I10").Select
des.Protect Password:="TIMESHEET", DrawingObjects:=True,
Contents:=True, Scenarios:=True
des.EnableSelection = xlUnlockedCells
des2.Save
des2.Close
src.Activate
Else
MsgBox "NO FILE NAME", vbCritical, "ERROR"
End If

End Sub

The macro above open Range("D20").value Workbook and in that workbook
copy data into old workbook. In old workbook in Range("H3:M3") I have
different workbook names. I want that when macro copy data from new
workbook to old workbook it should check Range("H3:M3") and if any
cell value match with Range("D20").value it should paste that data one
cell below of that cell. At the moment macro copies data fine but i
can get to paste data one cell below the macthed value. I think where
it say "src.Range("H" & I)" and "src.Range("I" & I)" that need to be
something else. Please can you help

 

[Joel]

Does this work

Sub import()

Set src = Workbooks("Book5.xlsm").Sheets("Sheet1")
BkName = src.Range("D20").Value
If BkName <> "" Then
Workbooks.Open Filename:= _
"C:\My Document\2008-2009\TIMESHEETS\" & BkName & ".xlsm"
Set des = Workbooks(BkName & ".xlsm").Sheets("TIMESHEET")
Set des2 = Workbooks(BkName & ".xlsm")
des.Unprotect Password:="TIMESHEET"
For I = 4 To 43
Set C = src.Range("H3:M3").Find(what:=BkName, _
LookIn:=xlValues, lookat:=xlWhole)
If C Is Nothing Then
MsgBox ("Cannot find : " & BkName)
Else
C.Offset(1, 0) = Format(des.Range("I" & ((3 * I) - 2)), "0%")
C.Offset(1, 1) = Format(des.Range("J" & ((3 * I) - 2)), "0%")
End If
Next I
des.Range("I10").Select
des.Protect _
Password:="TIMESHEET", _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True
des.EnableSelection = xlUnlockedCells
des2.Save
des2.Close
src.Activate
Else
MsgBox "NO FILE NAME", vbCritical, "ERROR"
End If

End Sub

 

[K]

Does this work

Sub import()

Set src = Workbooks("Book5.xlsm").Sheets("Sheet1")
BkName = src.Range("D20").Value
If BkName <> "" Then
Workbooks.Open Filename:= _
   "C:\My Document\2008-2009\TIMESHEETS\" & BkName & ".xlsm"
Set des = Workbooks(BkName & ".xlsm").Sheets("TIMESHEET")
Set des2 = Workbooks(BkName & ".xlsm")
des.Unprotect Password:="TIMESHEET"
For I = 4 To 43
   Set C = src.Range("H3:M3").Find(what:=BkName, _
      LookIn:=xlValues, lookat:=xlWhole)
   If C Is Nothing Then
      MsgBox ("Cannot find : " & BkName)
   Else
      C.Offset(1, 0) = Format(des.Range("I" & ((3 * I) - 2)), "0%")
      C.Offset(1, 1) = Format(des.Range("J" & ((3 * I) - 2)), "0%")
   End If
Next I
des.Range("I10").Select
des.Protect _
   Password:="TIMESHEET", _
   DrawingObjects:=True, _
   Contents:=True, _
   Scenarios:=True
des.EnableSelection = xlUnlockedCells
des2.Save
des2.Close
src.Activate
Else
MsgBox "NO FILE NAME", vbCritical, "ERROR"
End If

End Sub










- Show quoted text -

Thanks Joel it works fine. i just changed the lines in your code (see
below)

C.Offset(1, 0) = Format(des.Range("I" & ((3 * I) - 2)), "0%")
C.Offset(1, 1) = Format(des.Range("J" & ((3 * I) - 2)), "0%")

to

C.Offset(I, 0) = Format(des.Range("I" & ((3 * I) - 2)), "0%")
C.Offset(I, 1) = Format(des.Range("J" & ((3 * I) - 2)), "0%")

1 into I