Hi Jusip16,

As per your sample data, the following code will do as requested.

The result will be placed in a second sheet. First sheet is called Sheet1 and the second sheet is called Sheet2. Either name your sheets like that or find those sheet references in the code and change them to match your (easily done by selecting entire code [CTRL+a] and use the find/replace window [CTRL+h]).

Here is the code:

Sub RunMe()
Dim x, lRow As Integer
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Sheets("Sheet1").Select
With Sheets("Sheet2")
Do
x = x + 1
If Cells(x, "C").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "C").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "C").Value
End If
If Cells(x, "D").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "D").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "D").Value
End If
If Cells(x, "E").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "E").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "E").Value
End If
If Cells(x, "F").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "F").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "F").Value
End If
If Cells(x, "G").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "G").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "G").Value
End If
If Cells(x, "H").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "H").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "H").Value
End If
If Cells(x, "I").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "I").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "I").Value
End If
If Cells(x, "J").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "J").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "J").Value
End If
If Cells(x, "K").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "K").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "K").Value
End If
If Cells(x, "L").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "L").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "L").Value
End If
If Cells(x, "M").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "M").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "M").Value
End If
If Cells(x, "N").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "N").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "N").Value
End If
Loop Until x = lRow
End With
End Sub

Best regards,

Trowa

Josh- Mar 20, 2015 at 08:37 PMCould you help me with a similar question...The difference for me is that I want to paste a specific amount of times (100).

So as of now I have,

If Application.WorksheetFunction.CountA("B:B") = 0 Then

[B1].Select

Else

On Error Resume Next

Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select

If Err <> 0 Then

On Error GoTo 0

[B65536].End(xlUp)(2, 1).Select

End If

On Error GoTo 0

End If

Application.CutCopyMode = False

ActiveCell.FormulaR1C1 = "=NOW()"

And I would like the formula to be pasted the same way overt the next 99 cells so I have 100 cells all in a row with the date and time.

To repeat the code you have until you reach row 100, you can add "

Do" at the start and "Loop Until ActiveCell.Row = 100" at the end.If this doesn't suffice then please explain your query in full detail.

Best regards,

Trowa