VBA script for conditional copy, format & paste from workbook1 to workbook2

writetoevv

Board Regular
Joined
Mar 9, 2012
Messages
71
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
In workBook1, i have five columns (A,B,C,D,E) with data. Here, each row is a separate record & is going have unique data.
sample data is given below.

A B C D E
1 Q1 A1 A2 A3 A4
2 Q2 B1 B2 B3 B4

In workBook1, when i execute a VBA script , the following needs to done sequentially.
1. First, create a new workbook (for example workbook2). and, steps 2 to 6 should be repeated for all rows of workbook 1.
2. value Q1 of workbook1 should be copied to B2 in workbook2
3. if value A1 cell is in green color, then value A1::1;; should be add/appended to I2 column in workbook2. Else, append A1::0;; to I2 column of workbook2.
4. if value A2 cell is in green color, then value A2::1;; should be appended to I2 column of workbook2. Else, append A2::0;; to I2 column of workbook2.
5 if value A3 cell is in green color, then value A3::1;; should be appended to I2 column of workbook2. Else, append A3::0;; to I2 column of workbook2.
6. if value A4 cell is in green color, then value A4::1;; should be appended to I2 column of workbook2. Else, append A4::0;; to I2 column of workbook2.
7. Save workbook2 & close workbook2.

Example: for your reference, I2 Column Workbook2 should be like below.
chandu::1;;Shekar::0;;Raju::0;;Gopal::0;;
Venkat::0;;Gopi::1;;Stephen::0;;minda::0;;

<tbody>
</tbody>

<tbody>
</tbody>

<tbody>
</tbody>
 
also, in new workbook , Q11111, Q22222,Q33333,Q4444 needs to be copied on B Coloumn of respective rows . [Pardon me, though i mentioned it in initial post, i missed this part in dropbox excel file. i will update.]
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
also, in new workbook , Q11111, Q22222,Q33333,Q4444 needs to be copied on B Coloumn of respective rows . [Pardon me, though i mentioned it in initial post, i missed this part in dropbox excel file. i will update.]

with bit of hands on, copying Q11111, Q22222,Q33333,Q4444 in B Coloumn of new workbook has been implemented & done.

however, ith column of new worksheet issue still exist.
Output on ith Column
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;

Thanks & Regards.
 
Last edited:
Upvote 0
1 obersationi noticed

code always going to else part of if ..else, because "val.Interior.ColorIndex returning -4142" & we are checking whether it is equal to 43.
as it is not matching or equal, it is always going to else part of code.
 
Upvote 0
As I mentioned on Post #4 , you have to make sure that the colorindex of the shade of green you use in your cells matches the colorindex in the code. Run the following macro and change the range (in red) to a cell that is colored in green. This will display the colorindex of the shade of green you are using. Replace the "43" in the code with the displayed colorindex. That should fix the problem.
Code:
Sub test()
    MsgBox Range([COLOR="#FF0000"]"E2"[/COLOR]).Interior.ColorIndex
End Sub
 
Upvote 0
As you said ,i used test(), got 14 as colorindex & used colorIndex as 14 in the macro you provided.
However, still the o/p remains same. it seems the value of 'val' is nothing on debug..i think it is the problem. further, it always going else part..pls check o/p.
Output on ith Column
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;
::0;;::0;;::0;;::0;;

Meanwhile, i tried a different approach..it is producing result which is 80% of my expectations. few small issues still exist. it needs to be fixed. i shared macro below.

O/P:--
A1111::0;;
B1111::1;;
C1111::0;;
D1111::0;;
A2222::0;;
B2222::0;;
C2222::1;;
D2222::0;;
A3333::0;;
B3333::0;;
C3333::0;;
D3333::1;;
A4444::1;;
B4444::0;;
C4444::0;;
D4444::0;;

<tbody>
</tbody>

Macro:
Sub writetoevv_Ultimate_Test()
Application.ScreenUpdating = False
Dim LastRow As Long, val As Range, scrWS As Worksheet, desWB As Workbook, x As Long: x = 2
Set srcws = ThisWorkbook.Sheets("Sheet1")

Dim rng As Range: Set rng = Application.Range("B1:E4")
Dim cel As Range
For Each cel In rng.Cells
With cel
For Each val In srcws.Range("B" & rng.Row & ":E" & rng.Row)
If cel.Interior.ColorIndex = 14 Then
Cells(x, 9) = cel & "::1;;"
Else
Cells(x, 9) = cel & "::0;;"
End If
Next val
x = x + 1
End With
Next cel

Application.ScreenUpdating = True


End Sub
 
Last edited:
Upvote 0
Click [URL="https://app.box.com/s/5qh1fz8qz0kpuju59ouleh1vulthg9d7"]here [/URL]to download your file. It seems to be working properly for me.

Code:
Sub writetoevv()
    Application.ScreenUpdating = False
    Dim LastRow As Long, rng As Range, val As Range, scrWS As Worksheet, desWB As Workbook, x As Long: x = 2
    Set srcws = ThisWorkbook.Sheets("Sheet1")
    LastRow = srcws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set desWB = Workbooks.Add
    For Each rng In srcws.Range("A1:A" & LastRow)
        Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = rng
        For Each val In srcws.Range("B" & rng.Row & ":E" & rng.Row)
            If val.Interior.ColorIndex = 14 Then
                Cells(x, 9) = Cells(x, 9) & val & "::1;;"
            Else
                Cells(x, 9) = Cells(x, 9) & val & "::0;;"
            End If
        Next val
        x = x + 1
    Next rng
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
This is what I got.
<b>Sheet1</b><br /><br /><table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:64px;" /><col style="width:251px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >B</td><td >C</td><td >D</td><td >E</td><td >F</td><td >G</td><td >H</td><td >I</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >Q11111</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td >A1111::0;;B1111::1;;C1111::0;;D1111::0;;</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >Q22222</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td >A2222::0;;B2222::0;;C2222::1;;D2222::0;;</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >Q33333</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td >A3333::0;;B3333::0;;C3333::0;;D3333::1;;</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >Q4444</td><td > </td><td > </td><td > </td><td > </td><td > </td><td > </td><td >A4444::1;;B4444::0;;C4444::0;;D4444::0;;</td></tr></table> <br />Excel Tabellen im Web darstellen - Excel Jeanie Html 4
 
Upvote 0
yes, that is correct format..appreciates..

donot know why im getting w/o values..i used ur vba script as it is except commenting following line..' LastRow = srcws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ...instead i used a static value of 5/10..but it didnt worked for me

could you share ur macro enabled excel sheet with me..pls
 
Upvote 0
Click the link in Post #16 for the file. You shouldn't have to change any line in the macro.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top