vba Copy Paste Conditional to put remark 1 2 3 .. etc

[DocAElstein]

Hi

What is the problem??

You want this…Suppose column B already has data
and after that I am runing the macro
then the result will be pasted to column C
and the result which we have to paste is 2
and again when I ran the macro then column C can have the data or it cant have
but if column C has data then the result should be paste as 3 and so on….


Have you tried Molly’s macro ??

I have tried Molly’s macro . ( your version here: http://www.excelfox.com/forum/showth...ll=1#post12846 ) it does this:

Start like this
_____ Workbook: Merge (1).xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E
1	Symbol
2	ACC
3	ADANIENT
4

Worksheet: Sheet3


Now Run it once … It does this

_____ Workbook: Merge (1).xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E
1	Symbol
2	ACC	1
3	ADANIENT	1
4

Worksheet: Sheet3

Now run it again… It does this

_____ Workbook: Merge (1).xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E
1	Symbol
2	ACC	1	2
3	ADANIENT	1	2
4

Worksheet: Sheet3

Now run it again… It does this..

_____ Workbook: Merge (1).xlsx ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E
1	Symbol
2	ACC	1	2	3
3	ADANIENT	1	2	3
4

Worksheet: Sheet3

and so on.............................

So it does exactly what you asked for

What is your problem ???


The macro from Molly is doing exactly what you are asking for !!!!

---

Sub STEP7_() '
Rem 1 Worksheets info
Dim Wbm As Workbook, Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
 Set Wbm = Workbooks("Merge (1).xlsx")
' Set Wbm = Workbooks.Open(ThisWorkbook.Path & "\Merge1.xlsx")  '   "\Merge.xlsx") '  change to suit
 Set Ws1 = Wbm.Worksheets("Sheet1"): Set Ws2 = Wbm.Worksheets("Sheet2"): Set Ws3 = Wbm.Worksheets("Sheet3")
Rem 2 data Input
Dim arrS1() As Variant, arrS2() As Variant, arrS3() As Variant
 Let arrS1() = Ws1.Range("A1").CurrentRegion.Value: arrS2() = Ws2.Range("A1").CurrentRegion.Value
'2b
 ReDim arrS3(1 To UBound(arrS1(), 1)) ' A 1 dimension array of arrays
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output

Rem 3
Dim cnt
    For cnt = 2 To UBound(arrS1(), 1) '  "row" count, cnt
    '2b)(ii)
    Dim Lc As Long: Let Lc = Ws3.Cells.Item(cnt, Ws3.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
     Let arrS3(cnt) = Ws3.Range("A" & cnt & ":" & CL(Lc + 1) & cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays
     Select Case arrS1(cnt, 9) ' column I
      Case "SELL" 'If column I is sell
        If arrS1(cnt, 11) > arrS2(cnt, 5) Then ' if column K is Greater than sheet2 of column E then
        ' do nothing
        Else
        Let arrS3(cnt)(1, UBound(arrS3(cnt), 2)) = UBound(arrS3(cnt), 2) - 1 ' Put in a value in last array "column"
        End If
      Case "BUY"  'If column I is buy
       If arrS1(cnt, 11) < arrS2(cnt, 6) Then  ' if column K is lower than sheet2 of column F then
       ' do nothing
       Else
       Let arrS3(cnt)(1, UBound(arrS3(cnt), 2)) = UBound(arrS3(cnt), 2) - 1 ' Put in a value in last array "column"
       End If
     End Select
    '3b) output "row"
     Let Ws3.Range("A" & cnt & "").Resize(1, Lc + 1).Value = arrS3(cnt)
    Next cnt
Rem 4    ....and after putting the remark clear sheet 1 and sheet 2
' Ws1.Cells.ClearContents
' Ws2.Cells.ClearContents
' Wbm.Save
' Wbm.Close
 
End Sub


Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function