I have one column of data with either "UP", "DOWN" or "" as values. I am trying to write code that states that for all rows, if the first cell is "UP" then check the next rows until I come to either "DOWN" or "UP", i.e. if the next row has a "" then check the next row until I come to either a "DOWN" or "UP".
I am very new to VBA, and have tried various options, but seem to only be able to bring back where there are consecutive "UP"s or "DOWNS" rather than where there is an "UP", a number of rows of "" and then another "UP".
This is my code:
Range("z1:z250").Select
Selection.ClearContents
For Row = 2 To 250
If Range("Y" & Row).Value = "UP" Then
For sRow = 3 To 250
If Range("Y" & Row + 1).Value = "UP" Then
Range("Z" & Row) = "MT-UP"
ElseIf Range("Y" & Row + 1).Value = "" Then
End If
Next
End If
Next
End Sub
I have tried to add code such as For Each c in Range (“Y3”:”Y250”) but this doesn't make it find the next UP, and makes it very slow. I have also tried GoTo next cell (although seem to understand this is frowned upon!) but this doesn't work either. Any help appreciated.
Not 100% clear if this is what you want but take a look...
Instead of nested loops I used a flag to mark when a second consecutive "UP" was found before encountering a "DOWN". From your description it seems there's no need to check for empty cells ("").
Sub MTTest()
Dim Row As Long
Dim MTRow As Long
Dim MTFlag As Boolean
Range("Z1:Z250").ClearContents
For Row = 2 To 250
If Range("Y" & Row).Value = "UP" Then
If MTFlag = True Then
Range("Z" & MTRow) = "MT-UP"
MTFlag = Flase
Else
MTFlag = True
MTRow = Row
End If
Else
If Range("Y" & Row).Value = "DOWN" Then MTFlag = False
End If
Next
End Sub
Related
At work I have a repetitive task of going through a list of account activity and changes where I have to delete blank spaces and lines that are not necessary for the maintenance I perform. For 80% of the these I am able to work a for each loop that is pretty inelegant but effective.
Example:
For Each c In ActiveSheet.UsedRange
If InStr(1, c.Value, SubString7) = 1 Then ' find earn lines and remove
c.EntireRow.Offset(1).Delete
c.EntireRow.Clear
c.EntireRow.Offset(-1).Delete
End If
Next
The substring is the descriptive title line for each type of transaction. The one I am having trouble with is variable, while the others are not. It can be 9 lines long or 6 lines long, and could also be positive or negative but each possibility comes with the same title line.
Based on everything I could find to try to figure it out, I need to use a loop, moving from bottom to top. I cannot get it to trigger with either InStr, nor left/right.
This is a cut down version of what I am trying now:
lr = Range("A" & Rows.Count).End(xlUp).Row
For rowcounter = lr To 0 Step -1
If VBA.Strings.Left(Cells(rowcounter).Value, 11) Like "Earn Manual" Then
If VBA.Strings.Left(Cells(rowcounter + 5).Value, 1) = "-" Then
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'this, several more times with different offsets for the required lines
Else
Cells(rowcounter).EntireRow.Offset(5).Delete 'different ones, finalizing removals on the negative value items
End if
Else
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'again, but with different offsets
Else 'There is one line for these that I have to split into two lines, not sure if this will even work as I cannot get it to trigger
Cells(rowcounter).EntireRow.Offset(8).Delete
Cells(rowcounter).EntireRow.Offset(7).Delete
Cells(rowcounter + 4).Value = VBA.Strings.Right(Cells(rowcounter + 3).Value, 25)
Cells(rowcounter + 3).Value = VBA.Strings.Left(Cells(rowcounter + 3).Value, 13)
End if
End If
End If
Next Rowcounter
I had originally had that first If line as:
If InStr(1, Cells(rowcounter).Value, SubString8) = 1 Then
I tried switching to Left() and Like but still no dice.
Attempting to provide sample of input/output
sample data:
Goal output from column A:
Retained Data
Update again, new and improved code that is still failing:
Next
For i = 1 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
If ws.Range("A" & i) Like "Earn Manual*" Then
If ws.c("A" & i + 5) Like "-*" Then
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 8) ' shows AVG, negative value
Else
Set Deleteme = c.Range("A" & i, "A" & i + 5) ' no AVG, negative value
End If
Else
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
Else
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
End If
End If
Else
Set Deleteme = Union(Deleteme, ws.Range("A" & i))
End If
Next A
There is no way that I can get this 100% correct because it was based of the OP's new and improve code, which has some flaws in its logic. My goal was to simply the overall syntax to make it easier to get right.
The problem with deletion with offset values is that the values move on you. My solution is to Union all rows to be deleted and delete them then after the loop is done. This is not only more efficient but it allows us to loop from top to bottom. This makes the code it much easier to follow.
When Union ranges in this way, you must first test to see if the target range to be deleted is Nothing. If the target range is Nothing, we Set it to the new range else we Union the two ranges. I wrote a subroutine UnionRange(), so that we would not have to repeat this process each time we needed to do a Union.
With blocks, Range.Offset() and Range.Resize() were used to simply the syntax. I feel like this is cleaner than concatenating addresses inside of a range (e.g. Range("A" & i + 5) and Range("A" & i, "A" & i + 8)).
Sub CleanUp()
With ThisWorkbook.Worksheets("Sheet1")
Dim r As Long
Dim rUnion As Range
For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(r, 1)
If .Value = "" Then
UnionRange rUnion, .Offset(0)
ElseIf .Value Like "Earn Manual*" Then
If .Offset(6).Value Like "Avg*" Then ' shows AVG, negative value
UnionRange rUnion, .Offset(8)
Else ' no AVG, negative value
UnionRange rUnion, .Offset(5)
End If
Else
'This can't be right
If .Offset(6).Value Like "Avg*" Then 'If Like "Avg*" Then Delete These Cells
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
Else 'Hell If Not Like "Avg*" Then Delete The Same Cells Anyway
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
End If
End If
End With
Next
End With
If Not rUnion Is Nothing Then
Application.ScreenUpdating = False
rUnion.EntireRow.Delete
End If
End Sub
Sub UnionRange(ByRef rUnion As Range, ByRef Cell As Range)
If rUnion Is Nothing Then
Set rUnion = Cell
Else
Set rUnion = Union(rUnion, Cell)
End If
End Sub
I got it working just fine, but it is painfully slow. The first function that renames some cells runs really quick, but the while loop that deletes certain merged cell rows takes over a minute for multiple sheets.
Here is the relevant code:
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, rowtofilter).End(xlUp).Row
'Search for merged cells and not "string1" in column2 and not "string2" in column4, replace text
For i = rowtofilter To LastRow
If Range(ColumnLetter1 & i).MergeArea.Cells.Count > 1 And Range(ColumnLetter2 & i) <> "string1" And Range(ColumnLetter4 & i) <> "string2" Then
Range(ColumnLetter3 & i).Value = "Merged Cells"
End If
Next i
'Search for merged cells and not "string1" in column2 and not "string2" in column4, delete rows
i = LastRow - rowtofilter
Do While i > (rowtofilter - 1)
If Range(ColumnLetter1 & i).Value = 0 And Range(ColumnLetter2 & i) <> "string1" And Range(ColumnLetter4 & i) <> "string2" Then
Range(ColumnLetter1 & i).EntireRow.Delete
End If
i = i - 1
Loop
If you haven't yet, add application.screenupdating=false at the beginning and application.screenupdating=true at the end of your code to speed things up.
Then, if still slow, do the deletion all at once:
Dim rgToDelete As Range
i = LastRow - rowtofilter
Do While i > (rowtofilter - 1)
If Range(ColumnLetter1 & i).Value = 0 And Range(ColumnLetter2 & i) <> "string1" And Range(ColumnLetter4 & i) <> "string2" Then
If rgToDelete Is Nothing Then
Set rgToDelete = Range(ColumnLetter1 & i)
Else
Set rgToDelete = Union(rgToDelete , Range(ColumnLetter1 & i))
End If
End If
i = i - 1
Loop
rgToDelete .EntireRow.Delete
Instead of using Rows.Count, only work with the UsedRange. Worksheet.UsedRange.Rows.Count
Hide the sheet while doing the second bit. Excel wants to update the screen with every deleted row. By hiding the sheet, you stop that nonsense. Worksheet.Visible = xlSheetVeryHidden
If there are calculations based on the rows being deleted, turn off automatic calculations while doing the delete. In fact, you might just do it anyway. This will prevent Excel from recalculating the sheet on every delete. Application.Calculation = xlCalculationManual
Remember to turn everything back on when you're done.
*Note that, in the above examples, Worksheet should be replaced by a reference to whatever worksheet you are using.
I wrote if condition which is shown below, it looks for value "Current Status:" in row A and copy B value from that row to other sheet, if not not found "0" is placed in a cell, it works fine. Sometimes value "Current Status:" might be in a different cell than A18, it might show up in the range from A16 to A20, how can I modify that code to find it within the range and copy corresponding value?
If ws.Range("A18") = "Current Status:" Then
.Range("V" & NewRow) = ws.Range("B18")
Else
.Range("V" & NewRow) = "0"
End If
Just put your code in a For loop... or use VLookup like Scotty suggested. It's basically the same thing. A For loop is more flexible but less optimized (VLookup is faster). They both run on the order of fractions of a μs/cell.
For Each c In Range("A16:A20")
If c.Value2 = "Current Status:" Then
.Range("V" & NewRow) = c.Offset(0, 1)
Exit For
Else
.Range("V" & NewRow) = "0"
End If
Next
If using a For loop, this is a little bit more code than what's above but a better structure...
'Define a value holder variable where it's scope makes sense
Dim NewValue As String
'... other code here ...
'Default: NewValue = ""
NewValue = ""
For Each c In Range("A16:A20")
If c.Value2 = "Current Status:" Then
NewValue = c.Offset(0, 1)
'Exit For is optional in this case. It matters if
'there are multiple matches... do you want first or last result?
Exit For
End If
Next
'Assign NewValue to cell
.Range("V" & NewRow) = NewValue
Use Vlookup:
.Range("V" & NewRow) = "0"
On Error Resume Next
.Range("V" & NewRow) = Application.WorksheetFunction.VLookup("Current Status:", ws.Range("A:B"), 2, False)
On Error GoTo 0
This will put 0 in the cell then try to replace it with the value returned from the vlookup. If "Current Status:" is not found in column A on ws then it will throw an error and be ignored leaving 0 in the cell.
If the value is found it will return the value in Column B and put that in place of the 0
I have 32.000 rows with data. Some data are in a different place and I want to join them with something that I can apply to all rows and not manually. Each "group" have the same ID, in this example is "XPTO"
I have something like this now (but with more columns):
I want it to be like this:
The problem is that I need a clever way, because they are not always exactly like this example. Some of them have 10 rows with the same ID "XPTO" (example)
I am struggling with this =/ ty
Here's how I would approach this.
1) From your comment, I understand that the logic is positional (the first one on the left (Casteloes de) goes with the first one on the right (R Dr Antonio) for the matching value in column A. If that is true, then I would insert a column where you start numbering sequentially, then Fill Down to get sequential numbers all the way to the end. This will help preserve the positional logic if you need to sort or rearrange your data. It will also help you with the logic of "first match", "second match", etc.
2) My next step would be to separate the two sets of data into separate tables/tabs (with the sequentially numbered column appearing in each) and use INDEX/MATCH. The recent answer here will help you with how to increment the match: Is there such thing as a VLOOKUP that recognises repeated numbers?
3) Alternative - this may even be easier, although you'll want to do extensive data checking to make sure nothing got screwed up. With the two tables from step 2, sort by any column with data in it, then delete the blank rows from each table. Then, sort each by the sequentially numbered column to return to the original order. At that point you may be able to just copy and paste. Check carefully for errors if you do this.
I am positive that the solution above given by CriketBird work, at least it has a good logic to solve it, but since I am a newbie in excel, I couldn't figure it out how to solve it that way.
So I solved it by using VBA in excel...(maybe I went too far for this simple problem, but it was my only option).
I will leave the code here if someone want it for a similar situation. (just select the first column and row your table starts and hit run)
Function Area(medico As String) As Integer
Do While countOk < 1
If medico = ActiveCell.Value Then
ActiveCell.Offset(1, 0).Select
rowCount = rowCount + 1
Else: countOk = 1
End If
Loop
Area = rowCount
End Function
Sub Teste()
Dim PaginaMedico As String
Dim totalrowCount As Integer
Dim rowCount As Integer
Dim countOk As Integer
Dim right As Integer
Dim left As Integer
Dim listaleft As New Collection
Dim listaright As New Collection
rowCount = 1
rowOk = 0
totalrowCount = 0
right = 0
left = 0
Do While ActiveCell.Value <> 0
PaginaMedico = ActiveCell.Value
rowCount = Area(PaginaMedico)
totalrowCount = totalrowCount + rowCount
Range("A" & (totalrowCount - (rowCount - 1))).Select
For i = ((totalrowCount + 1) - rowCount) To totalrowCount
If IsEmpty(Range("E" & (i)).Value) And IsEmpty(Range("F" & (i)).Value) Then
Range("T" & (i)).Value = "Empty"
ElseIf Not IsEmpty(Range("E" & (i)).Value) And Not IsEmpty(Range("F" & (i)).Value) Then
Range("T" & (i)).Value = "Full"
ElseIf Not IsEmpty(Range("E" & (i)).Value) And IsEmpty(Range("F" & (i)).Value) Then
left = left + 1
listaleft.Add i
ElseIf IsEmpty(Range("E" & (i)).Value) And Not IsEmpty(Range("F" & (i)).Value) Then
right = right + 1
listaright.Add i
End If
Next i
If Not (right = left) Then
Range("T" & totalrowCount).Value = "BOSTA"
right = 0
left = 0
End If
If listaleft.Count = listaright.Count Then
For i = 1 To listaleft.Count
Range("F" & listaright(1) & ":" & "S" & listaright(1)).Cut Range("F" & listaleft(1) & ":" & "S" & listaleft(1))
listaright.Remove (1)
listaleft.Remove (1)
Next i
End If
Set listaleft = New Collection
Set listaright = New Collection
Range("A" & (totalrowCount + 1)).Select
Loop
End Sub
this is my first time using the site, so forgive me for any inept explaining. I have a working macro to hide/unhide rows based on content of the rows, I just want it to be faster. Using a check box, when the box is checked, all rows with an "x" in column D get unhidden, those without an "x" get hidden. Same thing happens when it is unchecked, except it references column C, not D.
Right now, this code works. It's just a little slower than I'd like, since I'm sharing this with a bunch of people. Any ideas for how to speed it up? I'm pretty darn new to VB (the internet is astoundingly wise and a good teacher), but that doesn't matter. I already improved the code - before it selected each row, then referenced the column, and it was awful. Any ideas to speed it up (preferably without moving the screen) would be great.
Thanks so much folks,
DS
Sub NewLuxCheck()
Dim x As Integer
NumRows = Range("A42", "A398").Rows.Count
Range("A42").Select
If ActiveSheet.Shapes("checkbox2").OLEFormat.Object.Value = 1 Then
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("D" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
Else
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("C" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
End If
MsgBox ("Done")
End Sub
You could use array formula and let Excel to return array with row-numbers where 'x' value occures. It will be quicker but you'll have to reorganise your code and create separate functions etc.
Here example where array formula finds rows whre in column 'D' the cell has value 'x'. Then string of this row numbers is created in form of "A1,A5,A10" ...means 'x' was found in rows 1,5,10. And finally Range(rowsJoind).EntireRow.Hidden is used for all the rows to be hidden/un-hidden in one step.
For rows with value different then 'x' you'll have to use formula like '=IF({0}<>""x"", ROW({0}), -1)'.
Sub test()
Dim inputRange As Range
Dim lastRow As Long
Dim myFormula As String
Dim rowsJoined As String, i As Long
Dim result As Variant
With Worksheets("Base")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set inputRange = .Columns("D").Resize(lastRow)
Application.ReferenceStyle = xlR1C1
myFormula = "=IF({0}=""x"", ROW({0}), -1)"
myFormula = VBA.Strings.Replace(myFormula, "{0}", inputRange.Address(ReferenceStyle:=xlR1C1))
result = Application.Evaluate(myFormula)
result = Application.Transpose(result)
Application.ReferenceStyle = xlA1
For i = LBound(result) To UBound(result)
If (result(i) > -1) Then
rowsJoined = rowsJoined & "A" & result(i) & IIf(i < UBound(result), ",", "")
End If
Next i
.Range(rowsJoined).EntireRow.Hidden = False
End With
End Sub