I have one of each ID (e.g. only one X and one Y) but I want each ID to repeat ten times with the corresponding number next to it.
I have very limited experience with VBA but this is a problem that seems to be solvable by VBA only.
What would the VBA code be?
If I understand correctly, you just want to copy each row in the file 10 times.
Try this:
Sub Macro1()
Dim i As Integer
Dim lastRow As Integer
Dim row As Integer
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
End With
Range("A1").Activate
For row = 1 To lastRow
For i = 1 To 9
Rows(ActiveCell.row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
ActiveCell.Offset(1, 0).Activate
Next i
ActiveCell.Offset(1, 0).Activate
Next row
End Sub
Related
I'm looking to update a cell on a sheet when it's left empty. If there is data in column B but not in column AA, I need to insert something into column AA.
I have made the following code but have failed to make it update the cell:
Range("B2").Select
Do Until IsEmpty(ActiveCell)
Dim LoopRowNo As Integer
LoopRowNo = ActiveCell.Row
If IsEmpty(Range(Cells(LoopRowNo, 26))) Then Range(Cells(LoopRowNo, 26)).Value = "01/01/1990"
ActiveCell.Offset(1, 0).Select
Loop
Hoping someone can point me in the right direction.
Use Range or Cells, but not both.
Don't Select.
With ActiveSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Dim i As Long
For i = 2 to lastRow
If IsEmpty(.Cells(i, "AA")) And Not IsEmpty(.Cells(i, "B")) Then
.Cells(i, "AA").Value = "01/01/1990"
End If
Next
End With
My sheet contains of cars that are placed at a certain location and need to be checked. This list is made twice a day and sometimes contains of 10 rows, sometimes 14, sometimes 12 etc. Now I would like to cut half of the rows and place it next to the other rows (in this case paste it in cell E). I would like to automate this process so in the VBA should be:
Count number of rows (X)
Cut the rows from X/2 to X
Paste the data in cell E1
I found this function which returns the middle cell. However, I would like to put this together in a sub.
Function Middle(r As Range) As Variant
Dim i As Long, j As Long
If r.Columns.Count > 1 Then
Middle = [#N/A]
Exit Function
End If
i = r.Row
j = r.Rows.Count
Middle = Cells(i + (j - 1) / 2, r.Column).Address
End Function
Sub cutting()
Range("Middle:C" & Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Cut
Range("E2").Select
ActiveSheet.Paste
Range("A1:C1").Select
Selection.Copy
Range("E1").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Range("E8").Select
End Sub
Before
After
You don't need to select the data to work with it.
Try:
Sub Test()
Dim lLastRow As Long
Dim lCutRow As Long
With ThisWorkbook.Worksheets("Sheet1") 'Change Sheet1 to the name of your sheet.
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Find last row in column A.
If lLastRow > 1 Then
lCutRow = (lLastRow / 2) + 1
.Range(.Cells(lCutRow, 1), .Cells(lLastRow, 3)).Cut Destination:=.Cells(1, 5) 'Paste to row 1, column 5 (E1).
End If
End With
End Sub
How can I, using the code below, replace "B5" by the "LastCol" so that I can activate the last non-blank cell in a row?
Sub LastColumnInOneRow()
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Worksheets("WARNINGS").Range("B5").Activate
ActiveCell.Offset(2, 0).Activate
End Sub
Thank you
You could do like this:
Sub LastColumnInOneRow()
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
With Worksheets("WARNINGS")
.Activate
.Cells(5,LastCol).Activate
End With
ActiveCell.Offset(2, 0).Activate
End Sub
The question took me a minute to figure out but try this
Worksheets("WARNINGS").Cells(6, LastCol + 1).Activate
at the end.
Sub LastColumnInOneRow()
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Long
With ActiveSheet
LastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Worksheets("WARNINGS").Cells(6, LastCol + 1).Activate
End Sub
Excellent! Many thanks. Here is the one I used at the end.
This was a first step towards sorting a pivot table results.
I saved a macro to sort the values but am now getting a "Subscript out of Range" warning when I try to run it. I guess the macro script is using a static range that I need to replace so that it can run to whatever Pivot Table results I may have.
But which line of the macro code do I need to replace?
Sub SortLargestWarningsCount()
'Find the last used column in a Row: row 1 in this example
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Worksheets("WARNINGS").Cells(6, LastCol).Activate
ActiveCell.Offset(1, 0).Activate
'Sort from Largest
ActiveSheet.PivotTables("WarningsPivotTable").PivotFields( _
"[Warnings].[Column5].[Column5]").AutoSort xlDescending, _
"[Measures].[Count of Column5]", ActiveSheet.PivotTables("WarningsPivotTable"). _
PivotColumnAxis.PivotLines(12), 1
End Sub
I need a macro to insert 2 cells moving existing data right. Sounds easy but been at it all day.
The issue is that the column B contains text and currency. If the cell contains currency, say $4661.52, I need to insert 2 cells, moving existing currency data right.
The length varies as does where the currency cells are. Late in the day
and confused.
Tried this and many variations :
Public Sub insertcells()
Const CLIENT As String = "B"
Dim Lastrow As Long
Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, CLIENT).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, CLIENT).Value2 Like "$*" Then
.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Check out this code.
Public Sub insertcells()
Const CLIENT As String = "B"
Dim Lastrow As Long
Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, CLIENT).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, CLIENT).Value2 Like "$*" Or IsNumeric(Cells(i, CLIENT).Value) Then
.Cells(i, CLIENT).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, CLIENT).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
The issue is that I have a function that deletes rows containing specific text:
Sub DeleteRowsContaining(text As String)
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
With ActiveSheet
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(2).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If .Value = text Then .EntireRow.Delete
'This will delete each row with the Value of text
'in Column A, case sensitive.
End If
End With
Next Lrow
End With
End Sub
After executing this code block I then would like to select the remaining text, however, any rows that were deleted from the end of a column still count when using the
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
command. The real issue is the error that happens when using the next command which is
Selection.End(xlDown).Offset(1, 0).Select
When using that command, if you have more than two empty rows selected, an error will be thrown. At this point I am at a loss, as all the ways that I can easily and dynamically check for the end of my data range are returning the location of a blank cell.
I am not sure if there is another way to delete a row that does not leave a cell selectable as if it had data, or if there is a way to trim the empty rows from a selection when excel seems to believe that the rows have something there.
Once you have completed deleting unwanted rows, to select the rows that remain run:
Sub SelectTheRest()
Dim N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & N).EntireRow.Select
End Sub