loop through a column and pull out specific cells - excel

I have a spreadsheet with a bunch of data all in one column and I'm looking to pull out specific data. I'm trying to see if a 'do until loop' will work.
I'm trying to get the loop to stop when it see "directory*" as part of the cell for example Directory of G:\Example. Until then the loop should look through the Cells and if it doesn't start with a number copy that cell to another sheet/column.
Sub Order()
iRow = 1
Do Until Cells(iRow, 1) = "Directory*"
If Cells(iRow, 1) <> NumberatBeginning Then
Cells(iRow, 1).Copy _
Destination:=Worksheets("Sheet2").Range("A1")
End If
iRow = iRow + 1
Loop
End Sub
Any help would be appreciated

You're almost there, the IsNumeric function can be used in conjunction with the Mid (or Left) function to check the first character in the cell value and return True or False if the character is numeric. Try this:
Sub Order()
Dim iRow as Long, x as Long
iRow = 1
x = 1
Do Until Cells(iRow, 1).Value Like "Directory*"
If Not IsNumeric(Mid(Cells(iRow, 1).Value, 1, 1)) Then
Worksheets("Sheet2").Cells(x, 1).Value = Cells(iRow, 1).Value
x = x + 1
End If
iRow = iRow + 1
Loop
End Sub
You should avoid using copy and paste as it slows down code, it is always better to simply set the value of the cell.
Also, when you're looping through and copying the cells with non-numeric first characters and pasting them into Sheet2 your code is always pasting into the same cell, Range("A1"), assuming you want a list of the values you will need to increment this by adding a row each time a value is copied to Sheet2.

Related

Iterating through a column and deleting multiple rows based on the values in the column

I need to remove lines from an Excel file where the value nets to zero with another line. 1,000 lines out of 10,000 may end up being deleted.
I sort the lines by absolute value from largest to smallest (for now done manually, I can add this later), then iterating through the values and deleting the lines that net to zero.
I have written code to execute on 50 lines, however it doesn't work:
Sub delete_row()
Dim activerow As Integer
activerow = 2
Do
If ActiveSheet.Cells(activerow, 13).Select + ActiveCell.Offset(1, 0) = 0 Then
Rows("activerow:activerow + 1").Select
Selection.Delete Shift:=xlUp
Else: activerow = activerow + 1
End If
Loop Until activerow = 50
End Sub
I am new to VBA and programming.
as a beginning (explanations in comments):
Sub delete_row()
Dim iRow As Long ' in Excel sheet you can handle up to 1 million row
' Integer type reaches up to some 32 thousands
' Long type allows for far more
For iRow = Cells(Rows.Count, 13).End(xlUp).Row To 2 Step -1 ' step backwards from column M (column index 13) last not empty cell row index to 2
If Cells(iRow, 13).Value + Cells(iRow + 1, 13) = 0 Then Cells(iRow, 13).EntireRow.Delete Shift:=xlUp
Next
End Sub
when deleting rows you Always have to start from the last one and then loop bakwards, to avoid missing any line
you hardy really need to Select anything (look at This link
)

VBA insert row if I+2 contains certain text

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

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 Loop Column A action column B

I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub

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

Resources