VBA insert row if I+2 contains certain text - excel

So I have an excel sheet that can have anywhere from 5-1500 lines. Most lines have: 1) Title Row, 2) patient information, 3) blank row. Then it repeats. Some lines have 1) Title Row, 2) patient info, 3) additional patient info, 4)blank row. I need to insert a line between Rows 2&3 if there is info in row 3. Does this make sense?
Example:
--------A---------------------b-----------------c-------------------d--------
1-----acct #--------patient name------dr name------ date of service
2------123456-------Mickey Mouse-----Donald Duck--------1/4/19
3----------((((((((((((((all of this row is blank)))))))))))))))))))))----------
Or it could be this:
--------A---------------------b--------------------c-------------------d------
1-----acct #--------patient name--------dr name------ date of service
2------123456-------Mickey Mouse-----Donald Duck--------1/4/19
3------123456-------Mickey Mouse-----Donald Duck--------1/4/19
4----------((((((((((((((all of this row is blank)))))))))))))))))))))----------
Then this same format repeats throughout the sheet with different info of course. What I need is if row 3 has any info then insert a row between tows 2 & 3, but if row 3 is blank then skip to the next set.
This is the code I have so far but it is adding rows every other row no matter what.
Sub Macro()
Dim lastRow As Integer
lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.count).Row
Dim I As Long
For I = 6 To lastRow
If Cells(I + 2, 9).Text <> "" Then
Rows(I + 1).EntireRow.Insert Shift:=xlDown
lastRow=lastRow+1
End If
Next I
End Sub

As #BruceWayne stated in the comments, When inserting or deleting rows, columns or cells, it's helpful to iterate backwards. The Step parameter of a For-Next loop allows you to define how you would like to iterate. It defaults to Step 1. So instead of iterating from I = 6 to lastRow try
Dim lastRow As Long
Dim i As Long
lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
For i = lastRow To 6 Step -1
If Cells(i - 1, 9).Text <> "" And Cells(i, 9).Text <> "" Then
Rows(i).EntireRow.Insert Shift:=xlDown
End If
Next i
This would insert a row at your current iteration if both the current cell and the cell above it had data in them.
It's worth noting that if you were to iterate to row 1, the If statement above would raise an error, but you'd never need to.
EDIT:
If what you need is to only add a row between patient info and additional patient info, you'd need to find a consistently identifiable piece of data to add as a condition to the If statement.

Give this a try.
Customize the variables to fit your needs
Sub InsertRows()
' Define object variables
Dim rangeEval As Range
Dim currentCell As Range
' Define other variables
Dim sheetName As String
Dim rowCounter As Integer
' >>>> Customize this
sheetName = "Sheet1"
' Initialize the used range in column A ' Change the number in .Columns(1) to use another column
Set rangeEval = ThisWorkbook.Worksheets(sheetName).UsedRange.Columns(1)
' Loop through each cell in range
For Each currentCell In rangeEval.Cells
' We use this counter to check if we are every third row
rowCounter = rowCounter + 1
' If this is the third row and there is something in the cell, insert one row
If rowCounter Mod 3 = 0 And currentCell.Value <> vbNullString Then
currentCell.EntireRow.Insert
' Reset the counter if there is nothing in the cell
ElseIf currentCell.Value = vbNullString Then
rowCounter = 0
End If
Next currentCell
End Sub

Related

How to delete these empty rows

I want to delete empty rows, such as 3-10 and 16-19. I tried the following code but it is also deleting rows 1, 2 and 15.
Dim s1 as worksheet
Dim LastRow As Long
Set s1 = ThisWorkbook.Worksheets(9)
LastRow = s1.Range("D" & s1.Rows.Count).End(xlUp).Row
With s1.Range("D2:D" & LastRow)
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
Looking at #cybernetic.nomads comment, and the fact that I just had a quick go, there will be a better way to do this.
If you want to delete all the empty rows, you'll (probably) need a loop.
When you delete a row your code needs to take in to account that the row numbers change (delete row 1, and now row 2 is actually row 1). You can do this by looping backward, or by re-trying the current row until all empty rows are gone then increase the row number (like my example)
Sub main()
Dim Sheet As Worksheet: Set Sheet = ThisWorkbook.Worksheets("Sheet1")
Dim Row As Integer: Row = 2 ' start row
Do
If Row > Sheet.Range("D" & Sheet.Rows.Count).End(xlUp).Row Then ' break out once you've gotten to the end
Exit Do
End If
If Application.WorksheetFunction.CountA(Sheet.Rows(Row)) = 0 Then ' check if the row is empty
Sheet.Rows(Row).Delete xlShiftUp ' delete the row and shift up
Else
Row = Row + 1 ' row was not empty, move on to the next row
End If
Loop
End Sub
your code check only column D and deletes blanks there.
text in lines 1, 2 and 15 are in columns A and B.
perhaps you could use this twist in your code?
while removed, instead i is used to check single rows
Rows are checked from bottom up
if a row has 4 blanks in columns A:D, this row is deleted
Code
Dim s1 As Worksheet
Dim LastRow As Long
Dim i As Long
Set s1 = ThisWorkbook.Worksheets(9)
LastRow = s1.Range("D" & s1.Rows.Count).End(xlUp).Row
If WorksheetFunction.CountBlank(s1.Range("A2:D" & LastRow).Cells) > 0 Then
For i = 1 To LastRow - 2: '-2 means: row 2 will be checked last. Use '-1' to check row 1 as well
If WorksheetFunction.CountBlank(Range(Cells(LastRow - i, 1), Cells(LastRow - i, 4))) = 4 Then
Rows(LastRow - i).Delete
End If
Next i
End If
Note: if you are not dealing with many rows, you might consider using integer Instead of Long
A simple solution is to check last column to garantee entire empty row
lastline = s1.Cells(Rows.Count, 4).End(xlUp).Row
i = lastline
While (i > 0)
If (s1.Cells(i, Columns.Count).End(xlToLeft).Column = 1 And s1.Cells(i, 1).Value = "") Then
s1.Rows(i).EntireRow.Delete
End If
i = i - 1
Wend
Note that the loop is backwards because (i) delete a row reindex all of the others next and (ii) classical for condition (for i = 1 to lastline) is checked just once.

Excel 2016 VBA Delete Rows with certain criteria

I have the following data.
If the same task appears more than 2 rows, I need to delete the 3rd, 4th,...duplicate rows. The rows are already sorted by Task name and date modified. I only need the most current and 1 prior data (first 2 rows of the same task).
In the above image, Row 7, 8, 9, 13, 14, 15, 16, 17, ... should be deleted
This isn't as easy to pull of as it first seems it might be. Every time we loop rows and delete the row based on some criteria we run into issues. We delete the row we are on, and then move to the next row, but because we deleted the row we are on, we are already on the next row. It's like pulling the rug out from underneath us while we are walking.
To get around these we usually step backwards through a range and delete, but... because in this case we are only deleting based on what we've already found, we have to go forwards.
There's a few ways to deal with this. I think the safest and most robust way is by looping once to get a count of each term, then looping again and deleting the appropriate amount of rows based on what we found in the first loop. This way we have LOTS of control over what gets deleted and how far we step in each iteration. It also reduces the complexities that we would face in tracking what we've found, how much of it, if we need to delete the current row, and how to deal with the loop if we do.
Sub removeRows()
Dim rngRow As Range
Dim dictTerms As Scripting.Dictionary
'Initialize Dictionary
Set dictTerms = New Scripting.Dictionary
'Load up dictionary using the term as the key and the count as the value
' by looping through each row that holds the terms
For Each rngRow In Sheet1.Rows("3:17")
'Only upsert to dictionary if we have a valule
If rngRow.Cells(1, 1).Value <> "" Then
If dictTerms.Exists(rngRow.Cells(1, 1).Value) Then
'increment value
dictTerms(rngRow.Cells(1, 1).Value) = dictTerms(rngRow.Cells(1, 1).Value) + 1
Else
'Add to dictionary with value 1
dictTerms.Add Key:=rngRow.Cells(1, 1).Value, Item:=1
End If
End If
Next rngRow
Dim intRow As Integer: intRow = 3
Dim intCounter As Integer
Dim termCount As Integer
'Loop through rows starting at intRow(set to 3 above) and ending at 17 (possible max)
Do While intCounter <= 17
'Skip blank rows
If Sheet1.Cells(intRow, 1).Value <> "" Then
'grab the number of terms encounterd so we know how much to delete
termCount = dictTerms(Sheet1.Cells(intRow, 1).Value)
'If it's more than two, then delete the remaining
If termCount > 2 Then Sheet1.Rows(intRow + 2 & ":" & intRow + termCount - 1).Delete
'Increment past what we deleted (or found if we didn't delete anything)
intRow = intRow + 2 + (termCount <> 1)
'Set the loop counter.
intCounter = intCounter + termCount
Else
'We found a blank, just increment our loop counter
intCounter = intCounter + 1
intRow = intRow + 1
End If
Loop
End Sub
You'll need to go to Tools>>References and add Microsoft Scripting Runtime (check the checkbox next to it in the big list and hit OK) so we can use the Scripting.Dictionary.
You'll also need to edit references to Sheet1 to whatever Sheet you are on. And possibly references to Cells(1,1) changing that first 1 to whatever column we are analyzing (assumed Column "A" here). Lastly you'll need to tweak startRow and endRow setting those values to whatever is appropriate for you workbook.
#JNevill, when you mentioned counter for each task, I just thought of something simple, -- now I just need to figure out how to delete the rows with values greater than 2 in the new column...without getting the error Script out of Range or Delete Method of Range Class Failed
'Declare Variables
Dim tableName As String
Dim activeSheetName As String
Dim totalrows As Long
'Identify Active Sheet Name
activeSheetName = ActiveSheet.Name
'Identify Active Table Name
tableName = ActiveSheet.ListObjects(1).Name
'Identify total number of rows
totalrows = Worksheets(activeSheetName).Range(tableName).Rows.count '99
'Insert counter column
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Dim taskCounter As Long
Dim rowNum As Integer
rowNum = 2
taskCounter = 0
For a = 1 To totalrows + 1
If Range("A" & rowNum) = "" Then
taskCounter = 0
Range("B" & rowNum).Value = taskCounter
Else
taskCounter = taskCounter + 1
Range("B" & rowNum).Value = taskCounter
End If
rowNum = rowNum + 1
Next a

Excel VBA - Add rows as described in a table

I am trying to replicate this view where new rows in the bottom table are created based on the values in Column'A' of the top table.
Here is my code:
Sub testProc()
Worksheets("Sheet1").Activate
Dim r, count As Range
Dim LastRow As Long
Dim temp As Integer
'Dim lngLastRow As Long
Set r = Range("A:L")
Set count = Range("A:A")
LastRow = Range("F" & 9).End(xlUp).Row
'LastRow = Cells(Rows.count, MyRange.Column).End(xlUp).Row
For n = LastRow To 1 Step -1
temp = Range("A" & n)
If (temp > 0) Then
Rows(n + 1 & ":" & n + temp).Insert Shift:=xlDown
Range("H" & (ActiveCell.Row) - 2).Copy Range("E" & (ActiveCell.Row) - 1)
Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Activate
'Cells(ActiveRow, 8).Value.Cut
'Cells.Offset(2 - 6).Value.Paste
'Range("G" & (ActiveCell.Row)).Select
'ActiveCell.Offset(0 - Selection.Column + 1).Range("A1:AG1").Select
'Value = Range(G, H)
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(1, -6).Paste
'ActiveCell.Offset(RowOffset:=1, ColumnOffset:=-6).Paste
'Range.Offset(1, -6).Paste
'Value = Range("G" & (ActiveCell.Row), "H" & (ActiveCell.Row)).Value
'ActiveCell.Offset(2, -6).Range
'ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
End If
Next n
End Sub
I do not know what I am doing and Excel is crashing with and without messages
The easiest solution to this would be to use two separate worksheets, but you can work around this pretty easily with some math or a cell with a reserved word. You also want to use as few reference variables as possible and let Excel tell you what the ranges are defined as by using contiguous ranges.
I'm not going to write the whole function for you, but give you the building blocks that will let you piece it together and hopefully you'll learn more as you do it.
Here's how to set up the object variables that you'll reference throughout the code:
Dim sourceSheet as Worksheet
Dim targetSheet as Worksheet
' replace with the names of sheets you want to use
sourceSheet = Worksheets("Sheet1")
targetSheet = Worksheets("Sheet2")
Now, for looping through the source table. If you know that the first row in the Sheet is always the Title row and your instructions start in row 2 then you can use this to loop through every instruction:
Dim sourceRowIndex = 2
While Not IsEmpty(sourceSheet.cells(sourceRowIndex, 1))
' ** do stuff here
' increment row index
sourceRowIndex = sourceRowIndex + 1
Wend
You could also use a For Each loop or a For Next or a Do While, take your pick once you understand the logic used.
Note that "Cells" takes two numbers - the row number then the column number. This is very handy when you're looping through a series of rows and columns and don't want to have to deal with addresses like A1 or C5.
This will loop through everything in the top table, but now you need to add an inner loop that will actually process the instructions. Add all of the code below after the While and before the Wend.
Finally, you need to add the rows to the Target. The trick here is to use the CurrentRegion property to figure out where the last row in the range is, then just add one to get the next blank row.
Dim targetFirstEmptyRow
' Look up the Current Range of cell A1 on target worksheet
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRegion.Rows + 1
Then to assign values don't use copy and paste, just assign the values directly. This will write the first row you have defined:
targetSheet.cells(targetFirstEmptyRow, 1).value = sourceSheet.cells(sourceRowIndex, 1).value
targetSheet.cells(targetFirstEmptyRow, 4).value = sourceSheet.cells(sourceRowIndex, 4).value
targetSheet.cells(targetFirstEmptyRow, 5).value = sourceSheet.cells(sourceRowIndex, 5).value
Then after you write out those three values you can get the next empty row by using this again (note that your sourceRowIndex hasn't changed):
targetFirstEmptyRow = targetSheet.cells(1,1).CurrentRange.Rows + 1
Using the cells(row, column) logic it's pretty easy to write the second row as well:
targetSheet.cells(targetFirstEmptyRow, 2).value = sourceSheet.cells(sourceRowIndex, 6).value
targetSheet.cells(targetFirstEmptyRow, 3).value = sourceSheet.cells(sourceRowIndex, 7).value
targetSheet.cells(targetFirstEmptyRow, 6).value = "Dev"
Adding the third row (when it's required) is nearly exactly the same as the second. However, you want to check to see if the third row is necessary:
If sourceWorksheet.cells(sourceRowIndex, 1) = 3 Then
' insert your third row here
End If
Here's the entire function in pseudo-code so you can piece it all together:
Set up worksheet variables
While loop through every Source row
Find next empty row in Target
Copy Row 1
Find next empty row in Target
Copy Row 2
If 3 rows
Find next empty row in Target
Copy Row 3
Increment Source Row Index
Wend
Finally, if you don't want to see the screen flashing (and you want to speed the code execution up a little) look into Application.Screenupdating to turn off screen redraw as this does its work. Just remember to turn it on again once you've finished processing everything.

Excel VBA: How to find duplicates and transpose?

I would like to ask your help for this task.
The excel sheet contains duplicated items in ColumnA. I want to combine these duplicates into one row. Please see the picture.
As the actual picture shows, there are three As in ColumnA. For every A there are some cells from ColumnB. Lets say those are the values to A. The values from every rows are marked with different colors seperately.
I want to combine A's values into one row, as the target picture shows.
The excel sheet was pre-sorted, so that all duplicates from ColumnA always appear together.
Please be noticed there are also items without duplicates: There is only one E in ColumnA. No transpose is required for this row.
Please also be noticed that there could be more duplicted items in ColumnA. E.g. 10x Ts, or 30x Ks.
To make the task easier, it is no need to delete the blank rows after the transformation.
The colors are used only to show the problem, there is no color in the excel sheet.
So far for this task.
Actually I asked a similar question before: Excel VBA: How to transform this kind of cells?
In the link there are some very good codes, but sadly I am not capable to rewrite the code for this task.
So please help me~
But please dont forget to have a happy weekend~
Thanks!
Try the code below ("bonus" feature, also removes the empty rows).
As you wrote in your post, the data is sorted according to Column A, and there are no empty rows in your data.
Sub TransposeDup()
Dim LastCol, LastColCpy As Long
Dim lrow As Long
lrow = 1
While Cells(lrow, 1) <> ""
If Cells(lrow, 1) = Cells(lrow + 1, 1) Then
LastCol = Cells(lrow, Columns.Count).End(xlToLeft).Column
LastColCpy = Cells(lrow + 1, Columns.Count).End(xlToLeft).Column
Range(Cells(lrow + 1, 2), Cells(lrow + 1, LastColCpy)).Copy Destination:=Cells(lrow, LastCol + 1)
Rows(lrow + 1).EntireRow.Delete
Else
lrow = lrow + 1
End If
Wend
End Sub
Something like the following should get you in the right direction. This doesn't copy formats, but it gets the values. You could tweak it to get where you need to go though:
Sub dedup_and_concat()
Dim intWriteCol As Integer
Dim intReadCol As Integer
Dim intWriteRow As Integer
Dim intReadRow As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim strPrevRowValue As String
'Start and end rows:
intStartRow = 1
intEndRow = 8
'initial values:
intWriteRow = 1
'Loop from your start row to your end row
For intReadRow = intStartRow To intEndRow 'beginning and ending rows
intReadCol = 2
'If we are at the first row, then just capture values
'Also if this is a new value, then reset all of the write variables
If intReadRow = intStartRow Or Sheet1.Cells(intReadRow, 1).Value <> Sheet1.Cells(intWriteRow, 1).Value Then
'set the row and initial column we are writing to
intWriteRow = intReadRow
intWriteCol = Sheet1.Cells(intReadRow, 1).End(xlToRight).Column() + 1
Else
'We are on a row that needs to be concatenated and deleted
'So loop through all of the columns to get their values
'And write their values to the read row and read col
Do Until Sheet1.Cells(intReadRow, intReadCol).Value = ""
Sheet1.Cells(intWriteRow, intWriteCol).Value = Sheet1.Cells(intReadRow, intReadCol).Value
'increment read and write columns
intWriteCol = intWriteCol + 1
intReadCol = intReadCol + 1
Loop
'remove this rows values
Sheet1.Rows(intReadRow).ClearContents
End If
Next intReadRow
End Sub

How to delete a row if it contains a string?

I have only one column of data. I need to write a macro that would go through all the values and delete all rows that contain the word "paper".
A B
1 678
2 paper
3 3
4 09
5 89
6 paper
The problem is that the number of rows is not fixed. Sheets may have different number of rows.
Here is another simple macro that will remove all rows with non-numeric values in column A (besides row 1).
Sub DeleteRowsWithStringsInColumnA()
Dim i As Long
With ActiveSheet '<~~ Or whatever sheet you may want to use the code for
For i = .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Row To 2 Step -1 '<~~ To row 2 keeps the header
If IsNumeric(.Cells(i, 1).Value) = False Then .Cells(i, 1).EntireRow.Delete
Next i
End With
End Sub
If you're confident that the rows in question would always contain "paper" specifically and never any other string, you should match based on the value paper rather than it being a string. This is because, particularly in Excel, sometimes you may have numbers stored as strings without realizing it--and you don't want to delete those rows.
Sub DeleteRowsWithPaper()
Dim a As Integer
a = 1
Do While Cells(a, 1) <> ""
If Cells(a, 1) = "paper" Then
Rows(a).Delete Shift:=xlUp
'Row counter should not be incremented if row was just deleted
Else
'Increment a for next row only if row not deleted
a = a + 1
End If
Loop
End Sub
The following is a flexible macro that allows you to input a string or number to find and delete its respective row. It is able to process 1.04 million rows of simple strings and numbers in 2.7 seconds.
Sub DeleteRows()
Dim Wsht As Worksheet
Dim LRow, Iter As Long
Dim Var As Variant
Var = InputBox("Please specify value to find and delete.")
Set Wsht = ThisWorkbook.ActiveSheet
LRow = Wsht.Cells(Rows.Count, 1).End(xlUp).Row
StartTime = Timer
Application.ScreenUpdating = False
With Wsht
For Iter = LRow To 1 Step -1
If InStr(.Cells(Iter, 1), Var) > 0 Then
.Cells(Iter, 1).EntireRow.Delete
End If
Next Iter
End With
Application.ScreenUpdating = True
Debug.Print Timer - StartTime
End Sub

Resources