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
Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
Could 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