Hi
Your explanation is ambiguous. It could be interpreted in different ways.
So I will interpret it as I choose. It will be luck if it gives you what you want......
Looking for highlighted cells requires interaction to the spreadsheet, since no format information is held in Excel values, that is to say using the .Value Property for the complete range will only distinguish Values, Formulas, Dates and Empty cells
But some worksheet functions are efficient, for example Range.Find , SpecilaCells, Copy, Offsett.
The solution that I have chosen to do will involve an initial adjustment so that I can detect the highlighted cells in a different way. Rem 2 makes the cell values formulas: http://www.excelfox.com/forum/showth...ll=1#post12570
Here is the macro, also in macro.xlsm
Code:
Sub PasteHighlightedCellsFromMatchedColumnRows() ' http://www.excelfox.com/forum/showthread.php/2425-Copy-and-paste-by-highlighted-colour
Rem 1 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Workbooks("1.xlsx").Worksheets.Item(1): Set Ws2 = Workbooks("2.xlsx").Worksheets.Item(1)
Rem 2 .... initial adjustment so that I can detect the highlighted cells in a different way
Dim Rng As Range
For Each Rng In Ws1.UsedRange.Offset(0, 2).Resize(, Ws1.UsedRange.Columns.Count - 2) ' We are intersted in the range offset 2 columns to the left of size 2 columns less than the main used range
If Rng.Interior.Color = 65535 Then
Let Rng.Value = "=" & """" & Rng.Value & """"
Else
End If
Next Rng
Rem 3 match column A stock name of 1.xlsx with column B of 2.xlsx and if it matches then copy the yellow highlighted colured cell data in that row of 1.xlsx and paste it to column L OF 2.xlsx
Dim Lr1 As Long: Let Lr1 = Ws1.UsedRange.Rows.Count
For Each Rng In Ws1.Range("A2:A" & Lr1 & "") ' Ws1 column A
Dim Lr2 As Long: Let Lr2 = Ws2.UsedRange.Rows.Count
Dim SrchRng As Range: Set SrchRng = Ws2.Range("B2:B" & Lr2 & "")
Dim RngMtch As Range
Set RngMtch = SrchRng.Find(what:=Rng.Value, After:=Ws2.Range("B2"), LookAt:=xlWhole, searchorder:=xlNext, MatchCase:=True) '
If RngMtch Is Nothing Then
Else ' a cell from column a 1.xlsx is matched to a cell from column B 2.xlsx
' copy the yellow highlighted colured cell data in that row of 1.xlsx
Rng.Offset(0, 1).Resize(, Ws1.UsedRange.Columns.Count - 1).SpecialCells(xlCellTypeFormulas, xlNumbers + xlTextValues).Copy
' paste it to column L OF 2.xlsx
Ws2.Range("L" & RngMtch.Row & "").PasteSpecial Paste:=xlPasteValues
End If
Next Rng ' Ws1 column A
Rem 4 save and close both the file after doing the process
Workbooks("1.xlsx").Close savechanges:=False
Workbooks("2.xlsx").Close savechanges:=True
End Sub
See also here: http://www.excelfox.com/forum/showth...ll=1#post12570
Alan
1.xlsx : https://app.box.com/s/dgufdfvw3lm3knkvwvp0xgiqpwarqf69
2.xlsx : https://app.box.com/s/51cykk4zd6ldan8puz70o3zyj0e17rwf
macro.xlsm : https://app.box.com/s/tbis0g4n6l6386df6xjwh4cirbtgphzl
Originally Posted by kinjal124
Reply With Quote
Bookmarks