I am trying to insert one row when the cell is column 4 doesn't have the same value. For some reason it is inserting 4 rows. It only happens at the start. What could be wrong?
Thanks for your help!
If Cells(j, 4) <> Cells(j - 1, 4) Then
Cells(j, 1).EntireRow.Insert
j = j + 1
End If
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If .Cells(i, 4) <> Cells(i - 1, 4) Then .Cells(i, 1).EntireRow.Insert
Next i
End With
End Sub
ScreenShot:
Related
I have a problem that I hope you can help me with.
The below code adds 1 day to todays day in Column B if it finds a repeated value in column A. However I want it to add 2 days if it gets repeated again and so on.
I have tried to illustrate how the codes work in the attached picture. So what I want is cell B10 in the picture to be 20/03/2021. I need to make it automatic so it can run for any number of repeated values.
Sub Add_date2()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 2 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = Date + 1
Else
Cells(iCntr, 2) = Date
End If
End If
Next
End Sub
Use Application.Countifs:
Sub Add_date2()
Dim ws As Worksheet
Set ws = ActiveSheet 'better to set the actual sheet WorkSheets("Sheet1")
With ws
Dim lastRow As Long
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim iCntr As Long
For iCntr = 2 To lastRow
If .Cells(iCntr, 1) <> "" Then
.Cells(iCntr, 2) = Date + Application.CountIfs(.Range(.Cells(2, 1), .Cells(iCntr, 1)), .Cells(iCntr, 1)) - 1
End If
Next
End With
End Sub
I have been googling a lot and I couldnt make this one work in any way.
I have a table of three columns (Name, Value1, Value2) with lots of names.
I need a vba to list all numbers between value 1&2 including them and their respective names.
For example for row A, 3000, 3003 make rows A, 3000; A, 3001; A, 3002; A, 3003 and then continue on the next name and split that name's range into individual numbers.
Is this even possible?
Thank you so much.
I wrote one based on an array to collect then transfer the values.
Sub expandValues()
Dim i As Long, j As Long, arr As Variant
With Worksheets("sheet5")
.Cells(1, "E").Resize(1, 2) = Array("Name", "Value")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arr(.Cells(i, "B").Value2 To .Cells(i, "C").Value2, 1 To 2)
For j = LBound(arr, 1) To UBound(arr, 1)
arr(j, 1) = .Cells(i, "A").Value2
arr(j, 2) = j
Next j
.Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0). _
Resize(UBound(arr, 1) - LBound(arr, 1) + 1, UBound(arr, 2)) = arr
Next i
End With
End Sub
Addendum:
Here is yours with an outer loop to process through the rows.
Sub FillIN()
Dim stri As Long, endi As Long
Dim nm As string, i as long, j as long
with workSheets(1)
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
nm = .Cells(i, "A").Value
strti = .Cells(i, "B").Value
endi = .Cells(i, "C").Value
For j= strti To endi
.Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0) = nm
.Cells(.Rows.Count, "E").End(xlUp).Offset(0, 1) = j
Next j
next i
end with
End Sub
Something like the following?
Option Explicit
Public Sub ListLines()
Dim ws As Worksheet, i As Long, y As Long, rowCounter As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet: rowCounter = 1
With ws
For i = 2 To GetLastRow(ws, 1)
For y = .Cells(i, 2) To .Cells(i, 3)
.Cells(rowCounter, 5) = .Cells(i, 1)
.Cells(rowCounter, 6) = y
rowCounter = rowCounter + 1
Next y
Next i
End With
Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, ByVal columNum As Long) As Long
With ws
GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Function
This is what I have so far. And it semi works. I need to make it jump on the next line ( it just repeats the first one forever ) and make it stop when done.
I havent been able to make it add +1 on the row portion of (Row, Column) in starti and endi and Name i after it is done with first row range. Mine also runs indefinitely so I also miss a stop once done.
Sub FillIN()
Dim ws As Worksheet
Dim stri As Long, endi As Long
Dim Name As Variant
Set ws = Sheets(1)
Name = Sheets(1).Cells(2, 1).Value
strti = Sheets(1).Cells(2, 2).Value
endi = Sheets(1).Cells(2, 3).Value
For i = strti To endi
ws.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Value = i
ws.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Value = Name
Next i
End Sub
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
My data is spreaded in many columns. In that, Column A and Column B has identical name (duplicates), while Column C to Q are values related to column B. I want to align column B to Column A while preserving subsequent values as it is.
NOTE: My question is very much similar to this one "Align identical data in two columns while preserving values in the 3rd in excel"
But in my case I want to preserve more subsequent columns (from C to Q). I played with code given as a solution by #Jeeped in that post but failed.
Can I get any help in this regards,
I have tried following code:
Sub aaMacro1()
Dim i As Long, j As Long, lr As Long, vVALs As Variant
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
vVALs = Range("B1:C" & lr)
Range("B1:C" & lr).ClearContents
For i = 1 To lr
For j = 1 To UBound(vVALs, 1)
If vVALs(j, 1) = .Cells(i, 1).Value Then
.Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j)
Exit For
End If
Next j
Next i
End With
End Sub
I have made an attempt to change range("B1:C" & lr) to range ("B1:Q" & lr), but it didnt work.
After that I have changed .Resize (1,2) to .Resize (1,3), and it copied two subsequent rows but when i inset a code with .Resize (1,4), didn't work.
Hope this edited post helps to answer my question.
With best
Based on the code in the original link, should work with any number of columns ...
Option Explicit
Option Base 1
Sub aaMacro1()
Dim i As Long, j As Long, k As Long
Dim nRows As Long, nCols As Long
Dim myRng As Range
Dim vVALs() As Variant
With ActiveSheet
nRows = .Cells(Rows.Count, 1).End(xlUp).Row
nCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols))
End With
nRows = nRows - 1
nCols = nCols - 1
vVALs = myRng.Value
myRng.ClearContents
For i = 1 To nRows
For j = 1 To nRows
If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then
For k = 1 To nCols
myRng.Cells(i, k).Value = vVALs(j, k)
Next k
Exit For
End If
Next j
Next i
End Sub
Test input ...
Provides this output ...
you can try this
Option Explicit
Sub AlignDupes()
Dim lRow As Long, iRow As Long
Dim mainRng As Range, sortRange As Range
With ActiveSheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set mainRng = .Range("A1:A" & lRow)
Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count)
.Sort.SortFields.Clear
End With
Application.AddCustomList ListArray:=mainRng
With sortRange
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
iRow = 1
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Do While iRow <= lRow
Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1)
.Rows(iRow).Insert
iRow = iRow + 1
lRow = lRow + 1
Loop
iRow = iRow + 1
Loop
End With
Application.DeleteCustomList Application.CustomListCount
End Sub
I have a small sample example sheet of data, which will be filled with much more data if I can get this process to work.
What I am trying to do is, based upon the number of cells that are filled in each row, insert the same number of blank lines under that same row and copy everything down all columns that are blank. I have attached two screenshots - a before and after of what the start and end look like, as well as the code used for implementing the blank row insert. So far, all it does is add 8 rows consistently, and is using an older version of Excel. I'm trying to translate it into the new VBA format, but I can't seem to get it to work.
Start:
The result I'm trying to achieve:
Code:
Sub IfYes()
Dim Col As Variant
Dim Y As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim C As Long
Dim StartRow As Long
Col = "AS"
Y = "Y"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Yes" Then
.Cells(R, Col).Offset(1, 0).Resize(8, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(8, 1).Value = .Cells(R, 1).Value
For C = 1 To 8 Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
I also have another bit of code that I've been trying to use to get this to function properly.
Dim wb1 As Workbook, ws1 As Worksheet
Dim lRow As Long
Dim LastRow As Range
Dim StartRow As Range
Dim i As Long
Set wb1 = Application.Workbooks.Open("Z:\Employee Folders\Jason\crystal spreadsheet - start.xls")
Set ws1 = wb1.Worksheets("AMZStart")
With ws1
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Cells(lRow, "B") = "AMZ" Then Rows(lRow).Offset(1, 0).EntireRow.Insert
Next lRow
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 1
StartRow = 1
For i = StartRow To LastRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")"
StartRow = i + 1
End If
Next
End With
End Sub
I find that storing the values in variant arrays can help.
Sub expand_Entries()
Dim v As Long, vAMZs As Variant, vVALs As Variant
Dim rw As Long, c1 As Long, c2 As Long, c As Long, cs As Long
With Worksheets("Sheet2")
c1 = Application.Match("status", .Rows(1), 0)
c2 = .Cells(1, Columns.Count).End(xlToLeft).Column
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
cs = Application.CountA(.Cells(rw, c1 + 1).Resize(1, c2 - c1))
If CBool(cs) Then
vVALs = .Cells(rw, 1).Resize(1, c1 - 1).Value2
With .Cells(rw, c1).Resize(1, cs + 1)
vAMZs = .Cells.Value2
.Offset(0, 1).ClearContents
End With
For c = UBound(vAMZs, 2) To LBound(vAMZs, 2) + 1 Step -1
.Cells(rw + 1, 1).Resize(1, c1 - 1).EntireRow.Insert
.Cells(rw + 1, 1).Resize(1, c1 - 1) = vVALs
.Cells(rw + 1, 8) = vAMZs(1, c)
Next c
End If
Next rw
End With
End Sub
You can use a the CountA Worksheet Function inside your IF block to determine the count of filled cells. Then just replace the 8's with the count of each row.
See code:
If .Cells(R, Col) = "Yes" Then
'get count
Dim iCells As Integer
iCells = WorksheetFunction.CountA(.Range("A" & R & ":R" & R))
.Cells(R, Col).Offset(1, 0).Resize(iCells, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(iCells, 1).Value = .Cells(R, 1).Value
For C = 1 To iCells Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If