How to copy only values in Excel?

Excel macro help required

• QUESTION: Thank you very much for your positive response. I will ask you questions sequentially so you will not be confused as I am. I know the logic but my loops are not working maybe because I am very new to VB. Hope you will help me to create this macro through which I will learn a lot and please suggest me what should I regularly do to be a master lik you in VB coding. Your answer: Dim sh1 as worksheet, dim bk2 as workbook Dim sh2 as worksheet, r1 as Range, cell as range set sh1 = Workbooks("Copy of Extract1.xls").Worksheets("Base Data") set bk2 = Workbooks("Copy of Mapping Details.xls") set r1 = sh1.Range("E2",sh1.Cells(sh1.rows.count,"E").End(xlup)) for each cell in r1 ' Loop through all the sheets in bk2 searching for ' the value in cell which is a value in column E of Sh1 for each sh2 in bk2.worksheets ' set r2 to refer to all cells in column A that have values set r2 = sh2.range("A1",sh2.cells(sh2.rows.count,"A").end(xlup)) ' use the countif function to see if the value exists in column A if application.countif(r2,cell) > 0 then ' the value exists so find where it is located res = Application.Match(cell,r2,0) set r2a = r2(res) ' now that we have found the cell, what to do with it exit for end if Next My question: 1. I have two workbooks: A) Copy of Extract1 with sheets: Base Data, Mapping & Split Data B) Copy of Mapping Details with sheets Bat, Ball, Stump & Pad 2. I need to start finding from cell E2 which is in workbook: Copy of Extract1 in worksheet: Base Data. Data/cell value in column E is in format x,y,z 3. First I need the macro to start finding value x in column A(1st column)of workbook: Copy of Mapping Details, starting from 1st worksheet:Bat 4. If it is not present look into second sheet:Ball, column A for the value x and loop until it finds the value i.e. if not in second sheet:Ball, find 3rd sheet:Stump,if still not found find 4th sheet:Pad (find only in cloumn A of every sheet) 5. If it is present, then do certain tasks which I will let you know in my next question. Pankaj ANSWER: Pankaj, I assume the extensions on the workbooks are .xls. If they are xlsx or xlsm change the code to reflect that (excel 2007) Sub ABC() Dim bk1 As Workbook, bk2 As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim r1 As Range, r2 As Range, r3 As Range Dim v As Variant, s As String, res As Variant Dim bFound As Boolean, cell As Range ' Set a reference to "copy of Extract1.xls" Set bk1 = Workbooks("Copy of Extract1.xls") ' set a reference to Base Data in bk1 Set sh1 = bk1.Worksheets("Base Data") ' set a reference to all the cells in column E of sh1 ' starting in cell E2 Set r1 = sh1.Range("E2", sh1.Cells(sh1.Rows.Count, "E").End(xlUp)) ' set a reference to Copy of Mapping Details Set bk2 = Workbooks("Copy of Mapping Details.xls") ' loop through all the cells in column E of sh1 in bk1 ' starting in cell E2. If Only E2 needs to be checked, then ' change ' set r1 = sh1.Range("E2",sh1.cells(sh1.rows.count,"E").End(xlup)) ' to set r1 = Sh1.Range("E2") For Each cell In r1 ' extract the "x" you speak of ' first see if there is a comma in the cell; if so use split ' to separate out the "x". If not see if there is anything in ' the cell. If there is, that is "x", if not we will not search ' on that cell If InStr(1, cell, ",", vbTextCompare) > 0 Then v = Split(cell, ",") s = v(LBound(v)) ElseIf Len(Trim(cell)) > 0 Then s = cell Else s = "" End If ' InStr(1, cell, ",", vbTextCompare) > 0 ' if we are searching ("x" established from cell) then If s <> "" Then bFound = False ' Loop through the sheets in Bk2 in tab order ' search in column A for the "x" value held in the variable "s" For Each sh2 In bk2.Worksheets Set r2 = sh2.Range("A1", _ sh2.Cells(sh2.Rows.Count, "A").End(xlUp)) ' "*" & s & "*" finds the search string as a substring ' just s finds the search string as the complete cell ' entry. as written I am looking for a substring ' if this is not correct, change it to ' Application.countif(r2,s) If Application.CountIf(r2, "*" & s & "*") > 0 Then res = Application.Match("*" & s & "*", r2, 0) ' or res = Application.Match(s, r2, 0) If Not IsError(res) Then Set r3 = r2(res) bFound = True Exit For End If 'Not IsError(res) End If 'Application.CountIf(r2, "*" & s & "*") > 0 Next 'Each sh2 In bk2.Worksheets '5. If it is present, then do certain tasks 'which I will let you know in my next question. if bfound then ' code goes here to do certain tasks msgbox s & " found at " & r3.Address(0,0,xlA1,True) end if ' bfound = True End If ' if s <> "" Next 'Each cell In r1 End Sub this code should be runable on your system. It will pop up a message box if value "x" is found. It will search for all the cells in E2 on down - so suggest you test it on a copy of your workbook and remove all but a couple of values in column E ---------- FOLLOW-UP ---------- QUESTION: How are you doing? Hope all is well. Your answer works and now I will proceed with next set of questions: Just FYI: I do not want Msgbox to appear :-) I hope you have added it just to retrieve the sheet in which the value is present... 5. If x is present in sheet "Bat" of workbook: Copy of Extract1 then goto column c sheet "Bat", start searching for 1st numeric number "1(one)" in column c in upward direction. 6. If numeric number "1(one)" is present for e.g. if x is present in cell A62 then start searching from C62 in upward direction for the numeric no. 1(one), If the numeric no. 1(one) is present in cell C46 then give the value of cell A46(assume A46 has value "a"), store the value "a" of A46 in a variable 7. Check if the stored value "a" is present in column D, cell D2(as we are searching value from cell E2, we will compare it with values of D2 and data/values in Coumnd D is in a,b,c format or may be only a or may be empty) in workbook: Copy of Extract1, sheet: Base Data. 8. If value "a" is present in cell D2 then goto next value present in cell E2 of workbook:Copy of Extract1, sheet: Base Data and search next value i.e. "y"(which is in format x,y,z). 9. Search value "y" in 1st sheet: Bat of workbook: Copy of Mapping Details, if not found keep searching other sheets in the workbook(which you have already done in previous reply). 10. If value "y" found in any sheet follow Step 5(with value y), 6(where 1st value will be y & 2nd value will be b) & 7(stored value will be b). 11. Alike Step 8 now If value "y" is not present in cell D2 then add it to column D, cell D2 and change the font to RED. Then find value "z" which is in E2, follow step 5, 6, 7 & 8/11 depending on the value found or not. 12. If there is no value in E3 move to E4 and if data is there follow Steps 5,6,7 & 8/11 depending on the value found or not. 13. Keep following/looping these steps until data in E ends and mapped to column D. 14. There is a last step of "Splitting" column D in new sheet and copy all the cells as it is which I will mention in next follow up. I hope this will give you the understanding what am I trying to do. Let me know if you have any questions on this. Pankaj ANSWER: Pankaj Sonawane, the message box was just for testing purposes so you could see that the macro was doing something. Test this on a copy of your two workbooks (copy them to another directory and restore the names used in the macro, open the copies and run the macro) Sub ABC() Dim bk1 As Workbook, bk2 As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim r1 As Range, r2 As Range, r3 As Range Dim v As Variant, s As String, res As Variant Dim r4 As Range, r5 As Range, Aval As String Dim ii As Long Dim bFound As Boolean, cell As Range ' Set a reference to "copy of Extract1.xls" Set bk1 = Workbooks("Copy of Extract1.xls") ' set a reference to Base Data in bk1 Set sh1 = bk1.Worksheets("Base Data") ' set a reference to all the cells in column E of sh1 ' starting in cell E2 Set r1 = sh1.Range("E2", sh1.Cells(sh1.Rows.Count, "E").End(xlUp)) ' set a reference to Copy of Mapping Details Set bk2 = Workbooks("Copy of Mapping Details.xls") ' loop through all the cells in column E of sh1 in bk1 ' starting in cell E2. If Only E2 needs to be checked, then ' change ' set r1 = sh1.Range("E2",sh1.cells(sh1.rows.count,"E").End(xlup)) ' to set r1 = Sh1.Range("E2") For Each cell In r1 ' extract the "x" you speak of ' first see if there is a comma in the cell; if so use split ' to separate out the "x". If not see if there is anything in ' the cell. If there is, that is "x", if not we will not search ' on that cell If InStr(1, cell, ",", vbTextCompare) > 0 Then v = Split(cell, ",") s = v(LBound(v)) For ii = LBound(v) To UBound(v) s = v(ii) bFound = False ' Loop through the sheets in Bk2 in tab order ' search in column A for the "x" value held in the variable "s" For Each sh2 In bk2.Worksheets Set r2 = sh2.Range("A1", _ sh2.Cells(sh2.Rows.Count, "A").End(xlUp)) ' "*" & s & "*" finds the search string as a substring ' just s finds the search string as the complete cell ' entry. as written I am looking for a substring ' if this is not correct, change it to ' Application.countif(r2,s) If Application.CountIf(r2, "*" & s & "*") > 0 Then res = Application.Match("*" & s & "*", r2, 0) ' or res = Application.Match(s, r2, 0) If Not IsError(res) Then Set r3 = r2(res) bFound = True Exit For End If 'Not IsError(res) End If 'Application.CountIf(r2, "*" & s & "*") > 0 Next 'Each sh2 In bk2.Worksheets '5. If it is present, then do certain tasks 'which I will let you know in my next question. If bFound Then ' code goes here to do certain tasks 'MsgBox s & " found at " & r3.Address(0, 0, xlA1, True) Set r4 = r3.Offset(0, 2) ' column C Do While r4.Row > 1 Set r4 = r4.Offset(-1, 0) If r4.Value = 1 Then Set r5 = r4.Offset(0, -2) Aval = r5.Value If InStr(1, cell.Offset(0, -1), Aval, _ vbTextCompare) = 0 Then cell.Offset(0, -1) = cell.Offset(0, -1).Value _ & "," & Aval cell.Offset(0, -1).Font.ColorIndex = 3 End If Exit Do Else ' a one was not found in column C End If Loop End If ' bfound = True Next 'ii = LBound(v) To UBound(v) End If ' InStr(1, cell, ",", vbTextCompare) > 0 Then Next 'Each cell In r1 End Sub ---------- FOLLOW-UP ---------- QUESTION: The above macro works upto an extent, however it does not works for a single value present in Column E for e.g. It works where commas are present but it does not works where commas are/is not present. My apologies, I forgot to inform that the data in column E would be in (x,y,z OR x,y OR x OR Empty) format. So it should also consider the single value present in column E, any cell, find the value and add if anything required to be added in column D. Also, The coloring part, the macro is coloring the whole cell of column D where data is been added, but we want to mark only the values which are been added to column D in red. For e.g. if in column D values, cell D5, (A,B,C(values/data)) are present and if (D,E(values/data)) are added, we want to mark only D %26 E as red not the whole cell. Same with single value, if only D is added to column D, cell D5 only D will be marked red and not the whole cell D5. Also, if there is single value present in column E, cell E5 (assume G) and column D, cell D5 is empty, in this case if data/value is been added it will be single and need to be marked in red. Hope this gives you the whole Idea. I will let you know the last step in my next set of questions. Thank again for all your help. Pankaj

• Answer:

  Pankaj Sonawane, I make a mock up of your two workbooks as I envision they are organized and tested this code. It acted as I expected - as I understand your requirement. Both procedures below need to be placed into your module. Test this on a copy of your workbook Sub ABC() Dim bk1 As Workbook, bk2 As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim r1 As Range, r2 As Range, r3 As Range Dim v As Variant, s As String, res As Variant Dim r4 As Range, r5 As Range, Aval As String Dim ii As Long, r6 As Range Dim bFound As Boolean, cell As Range ' Set a reference to "copy of Extract1.xls" Set bk1 = Workbooks("Copy of Extract1.xls") ' set a reference to Base Data in bk1 Set sh1 = bk1.Worksheets("Base Data") ' set a reference to all the cells in column E of sh1 ' starting in cell E2 Set r1 = sh1.Range("E2", sh1.Cells(sh1.Rows.Count, "E").End(xlUp)) ' set a reference to Copy of Mapping Details Set bk2 = Workbooks("Copy of Mapping Details.xls") ' loop through all the cells in column E of sh1 in bk1 ' starting in cell E2. If Only E2 needs to be checked, then ' change ' set r1 = sh1.Range("E2",sh1.cells(sh1.rows.count,"E").End(xlup)) ' to set r1 = Sh1.Range("E2") For Each cell In r1 ' extract the "x" you speak of ' first see if there is a comma in the cell; if so use split ' to separate out the "x". If not see if there is anything in ' the cell. If there is, that is "x", if not we will not search ' on that cell If InStr(1, cell, ",", vbTextCompare) > 0 Or Len(Trim(cell.Value)) > 0 Then If InStr(1, cell, ",", vbTextCompare) > 0 Then v = Split(cell, ",") s = v(LBound(v)) Else ReDim v(0 To 0) v(0) = cell.Value s = cell.Value End If For ii = LBound(v) To UBound(v) s = v(ii) bFound = False ' Loop through the sheets in Bk2 in tab order ' search in column A for the "x" value held in the variable "s" For Each sh2 In bk2.Worksheets Set r2 = sh2.Range("A1", _ sh2.Cells(sh2.Rows.Count, "A").End(xlUp)) ' "*" & s & "*" finds the search string as a substring ' just s finds the search string as the complete cell ' entry. as written I am looking for a substring ' if this is not correct, change it to ' Application.countif(r2,s) If Application.CountIf(r2, "*" & s & "*") > 0 Then res = Application.Match("*" & s & "*", r2, 0) ' or res = Application.Match(s, r2, 0) If Not IsError(res) Then Set r3 = r2(res) bFound = True Exit For End If 'Not IsError(res) End If 'Application.CountIf(r2, "*" & s & "*") > 0 Next 'Each sh2 In bk2.Worksheets '5. If it is present, then do certain tasks 'which I will let you know in my next question. If bFound Then ' code goes here to do certain tasks 'MsgBox s & " found at " & r3.Address(0, 0, xlA1, True) Set r4 = r3.Offset(0, 2) ' column C Do While r4.Row > 1 Set r4 = r4.Offset(-1, 0) If r4.Value = 1 Then Set r5 = r4.Offset(0, -2) Aval = r5.Value Set r6 = cell.Offset(0, -1) If InStr(1, r6, Aval, _ vbTextCompare) = 0 Then If IsEmpty(r6) Then r6.Value = Aval If InStr(1, cell, ",", vbTextCompare) > 0 Then r6.Font.ColorIndex = 3 End If Else ColorCell r6, Aval End If End If Exit Do Else ' a one was not found in column C End If Loop End If ' bfound = True Next 'ii = LBound(v) To UBound(v) End If ' InStr(1, cell, ",", vbTextCompare) > 0 Then Next 'Each cell In r1 End Sub Public Sub ColorCell(r As Range, Aval As String) Dim l As Long Dim s As String, vv As Variant l = Len(r) + Len(Aval) + 1 s = r.Value & "," & Aval ReDim vv(1 To l) For i = 1 To Len(r) vv(i) = r.Characters(i, 1).Font.ColorIndex Next For i = Len(r) + 2 To l vv(i) = 3 Next r = s For i = 1 To l r.Characters(i, 1).Font.ColorIndex = vv(i) Next End Sub