Vba : copy Transpose in 2 differents rows

[florianG]

Hi,

I am a beginner and for my first code I would to achieve a copy and transpose on 2 different rows, in function of an argument :
Exp : copy value in range A1:A8 if value in column B = "good" and paste in Range C1:F1 and Range C2:F2, avoiding blank and repetition in 2 ranges.

I started with that :


Sub Try()
Dim x As Integer

For x = 1 To 4

If Worksheets("sheet1").Range("B" & x) = "good" Then

Worksheets("sheet1").Range("A" & x).Copy
lastrow = Worksheets("sheet1").Range("J" & Rows.Count).End(xlUp).Row
Worksheets("sheet1").Range("J" & lastrow + 1).PasteSpecial Paste:=xlPasteValues
End If
Next x

Worksheets("sheet1").Range("J2:J5").Copy
Worksheets("sheet1").Range("C1:F1").PasteSpecial transpose:=True
Range("J2:J5").ClearContents

For x = 5 To 8

If Worksheets("sheet1").Range("B" & x) = "good" Then

Worksheets("sheet1").Range("A" & x).Copy
lastrow = Worksheets("sheet1").Range("J" & Rows.Count).End(xlUp).Row
Worksheets("sheet1").Range("J" & lastrow + 1).PasteSpecial Paste:=xlPasteValues
End If
Next x

Worksheets("sheet1").Range("J2:J5").Copy
Worksheets("sheet1").Range("C2:F2").PasteSpecial transpose:=True
Range("J2:J5").ClearContents
End Sub
but I think it's pretty slown to run and I have still blank cells.

I was thinking doing an offset after :


Dim cell As Range

For Each cell In Active Sheet.Range("C1:F1")

If IsEmpty(cell) Then
cell.Value = cell.offset(1, -1).Value
End If
Next cell

But I end up with repetition on the same values.

I hope it's clear enough and if someone can help me. thank you.

[jolivanes]

Sub Maybe()
If Cells(1, 2).Value = "good" Then
Cells(1, 3).Resize(, 4).Value = Application.Transpose(Cells(1, 1).Resize(4).Value)
Cells(2, 3).Resize(, 4).Value = Application.Transpose(Cells(5, 1).Resize(4).Value)
End If
End Sub

[jolivanes]

Or so?

Sub Maybe_So()
Dim ii As Long, i As Long, jj As Long, j As Long
ii = 3
For i = 1 To 4
If Cells(i, 2).Value = "good" Then Cells(1, ii).Value = Cells(i, 1).Value: ii = ii + 1
Next i
jj = 3
For j = 5 To 8
If Cells(j, 2).Value = "good" Then Cells(2, jj).Value = Cells(j, 1).Value: jj = jj + 1
Next j
End Sub