has helped 2162 users this month
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
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
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
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