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
Glad we were able to help! Love us? Write us a review! Rate CCM
6052 users have said thank you to us this month
Sub CopyValueDown() Dim lRow As Integer Sheets("Sheet 2").Select lRow = Range("A" & Rows.Count).End(xlUp).Row If lRow = 1 Then GoTo NextPartOfCode Range("E1:F1").AutoFill Destination:=Range("E1:F" & lRow) NextPartOfCode: End Sub
Sub RunMe() Dim CopyX, x As Integer CopyX = Sheets("Sheet2").Range("A1") Sheets("Sheet1").Select Range("A1").Copy Do x = x + 1 Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Loop Until x = CopyX Application.CutCopyMode = False End Sub
Sub RunMe() Dim CopyX, x As Integer CopyX = Sheets("Sheet2").Range("A1") Sheets("Sheet1").Select Range("A1").Copy Do x = x + 1 Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial Loop Until x = CopyX Application.CutCopyMode = False End Sub
Sub RunMe() Dim x, y, z As Integer x = Range("D" & Rows.Count).End(xlUp).Row For y = x To 2 Step -1 z = Cells(y, "D").Value - 1 Do Until z = 0 Rows(y).Copy Rows(y).Insert Shift:=xlDown z = z - 1 Loop Next y Application.CutCopyMode = False End Sub
Sub RunMe() Dim mCol, mRow As Integer Sheets("Sheet1").Select For Each cell In Range("A2:A" & Range("A1").End(xlDown).Row) mRow = cell.Row mCol = 2 Do mCol = mCol + 1 If Cells(mRow, mCol) <> vbNullString Then Range(Cells(mRow, "A"), Cells(mRow, "B")).Copy _ Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Cells(1, mCol).Copy Sheets("Sheet2").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) Cells(mRow, mCol).Copy Sheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) End If Loop Until Cells(mRow, mCol) = vbNullString Next cell End Sub
Sub ToyNumber() Dim toy, i As Integer toy = 3 'changed 1 to 3, to start pasting from row 3. For Each cell In Range("A1", Range("A1").End(xlDown)) For i = 1 To 14 Sheets("Result").Range("A" & toy).Value = cell.Value 'reference to the Result sheet added, also changed B to A. toy = toy + 1 Next i Next cell End Sub
Sub RunMe() Dim x, xRep, lRow As Integer lRow = Range("F" & Rows.Count).End(xlUp).Row For x = lRow To 1 Step -1 xRep = Range("F" & x).Value Do Until xRep = 1 With Rows(x) .Copy .Insert End With xRep = xRep - 1 Loop Next x Application.CutCopyMode = False End Sub
DON'T MISS
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