Copy cell content with an if condition + small loop (VBA Excel)

[Joe BR]

Hello everyone,

I really thought I could do it but after a morning having fun I decided to ask for help.

I have a data tab with some characteristics in the range B32:C43 (on the B column is the characteristic and on C is a "yes or no"). I want to copy the cell B content when the cell C value is "yes" to the sheet 5 starting from B17 onwards.

There is a catch, on row 40 there is a number (that goes from 1 to infinite). In the middle of the copy, I want to create as many lines as specified in C40 and fill them with "Trial X" (where X is the number).

It's something like this

Column A	Column B	Column C
Row 32	Moisture Exposition	Y
Row 33	Biological	N
Row 34	Screening	Y
Row 35	Gama X	N
Row 36	Gama Y	N
Row 37	Gama Z	N
Row 38	Gama T	N
Row 39	Alfa 32	Y
Row 40	Number of trials	5
Row 41	Overcount	Y
Row 42	Final testing	N

And this should generate in the sheet 5 something like this:

Column A	Column B
Row 17	Moisture Exposition
Row 18	Screening
Row 19	Alfa 32
Row 20	Trial 1
Row 21	Trial 2
Row 22	Trial 3
Row 23	Trial 4
Row 24	Trial 5
Row 25	Overcount

Can somebody help me?

 

[mumps]

Change the sheet name (in red) to suit your needs.

Sub CopyCell()
    Application.ScreenUpdating = False
    Dim v As Variant, arr() As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, cnt As Long, x As Long: x = 1
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets(5)
    v = srcWS.Range("B32", srcWS.Range("B" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = LBound(v) To UBound(v)
        If v(i, 2) = "Y" Then
            ReDim Preserve arr(x)
            arr(x) = v(i, 1)
            x = x + 1
        ElseIf IsNumeric(v(i, 2)) Then
            For cnt = 1 To v(i, 2)
                ReDim Preserve arr(x)
                arr(x) = "Trial " & cnt
                x = x + 1
            Next cnt
        End If
    Next i
    desWS.Range("B17").Resize(x).Value = Application.Transpose(arr)
    Application.ScreenUpdating = True
End Sub

 

[Joe BR]

Thanks @mumps ! Although one thing needs fixing, the macro is looking throughout the full column (until the end) and it should look only up to row 42 (there are other numbers not to be considered after that row). I tried to adjust directly on the line below replacing "B42" instead of "rows.count" but then it skipped the first lines.
v = srcWS.Range("B32", srcWS.Range("B" & Rows.Count).End(xlUp)).Resize(, 2).Value

Can you please help me again?

Thanks!

 

[mumps]

Try:

v = srcWS.Range("B32:B42").Resize(, 2).Value

 

[Joe BR]

Try:

v = srcWS.Range("B32:B42").Resize(, 2).Value

Yes sir! Thanks!

Final adjustment, it is copying the first "yes" on row 18 instead of 17 (which is not a problem, I even prefer like this now) but it is deleting the value that was on row 17 (on the destination). Any idea why?

 

[mumps]

This line of code starts pasting at row 17:

desWS.Range("B17").Resize(x).Value = Application.Transpose(arr)

I'm not sure why it is copying the first "yes" on row 18.

 

[Joe BR]

Not a problem, I can solve it!

Thank you very much!

 

[mumps]

You are very welcome.