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.
Assuming your data is located in column A, then the following code will place the result in column B:
Best regards,
Trowa
I have try this code
Sub RunMe()
Dim x, y As Integer
x = 1
For Each cell In Range("A1", Range("A1").End(xlDown))
For y = 1 To 80
Range("B" & x).Value = cell.Value
x = x + 1
Next y
Next cell
End Sub
but this is not working if we have only 1 cell used in column, if we have used only one cell in column . ablove code not working fine I=, its got hang the sheet
I have a similar kind of excel sheet which I want to convert and format to a particular usage. Please let me know where I can share the excel sheet.
Thanks in advance
Kunal
You can use a free file sharing site like wetransfer and post back the download link in a new thread along with you question.
Best regards,
Trowa