Identify range in an Excel outline group - excel

I have an Excel sheet that has data grouped using the outline method.
I'm having issues defining a range from the beginning of the group to the end of the group.
I have this data populating a listbox in a userform.
If a user selected any item in this group to delete I need to remove the whole group.
I think I am over thinking it but is there a good way to define this range?
Here is a sample of what I am starting with below
`Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
'if outline level should never drop below 2.
'If it is 2 then this will always be the beginning of the range.
If ActiveCell.Rows.OutlineLevel = 2 Then
y = ActiveCell.Row
Else
y = ActiveCell.Row + 3
'y= needs to look up until it see a 2 then go back down 1 row
End If
If ActiveCell.Rows.OutlineLevel <> 2 Then
x = ActiveCell.Row + 1
'x = needs to look down until it finds next row 2 then back up 1 row
Else
x = ActiveCell.Row
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Select '.Delete
End Sub`
Worked on it a little bit. Have the outline level stored as a value on the sheet in column AA.
Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
Dim Rng As Range
Dim C As Range
Dim B As Range
'if outline level shoudl never drop below 2.
'If it is 2 then this will always be the begining of the range.
If ActiveCell.Rows.outlinelevel = 2 Then
'If ActiveCell = 2 Then
y = ActiveCell.Row
Else
Set Rng = Range("AA:AA")
Set B = Rng.Find(What:="2", After:=ActiveCell,LookIn:=xlFormulas,LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
y = B.Offset(0, 0).Row
End If
If ActiveCell.Rows.outlinelevel <> 2 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
If ActiveCell.Rows + 1 = 3 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
x = ActiveCell.Row
End If
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Delete
End Sub

Try this:
Option Explicit
Public Sub RemoveGroup()
Dim grpStart As Range, grpEnd As Range, lvl As Long
Set grpStart = Sheet1.Range("A7").EntireRow 'test cell - A7
Set grpEnd = grpStart
lvl = grpStart.OutlineLevel
While lvl = grpStart.OutlineLevel 'find start of current group (up)
Set grpStart = grpStart.Offset(-1)
Wend
Set grpStart = grpStart.Offset(1) 'exclude 1st row in next group
While lvl = grpEnd.OutlineLevel 'find end of current group (down)
Set grpEnd = grpEnd.Offset(1)
Wend
Set grpEnd = grpEnd.Offset(-1) 'exclude 1st row in next group
With Sheet1.Rows(grpStart.Row & ":" & grpEnd.Row)
.ClearOutline
.Delete
End With
End Sub
Before and After:

Related

Highlighting Values In Column to Column Comparison using VBA

I am attempting to compare two columns in two separate sheets, each column contains data that is a string. My issue is that there is data in one column that is identical to the other in separate rows; therefore I have to check the entire column for the data before moving to the next. I am very inexperienced with VBA and am trying to make one portion of my job easier rather than comparing the columns by hand. I have piece wised the following code from research and trial and error. I am able to get the entire Column searched in my first Sheet, but only one value is being highlighted on the second sheet and then it is returning a value of "True" in the first column. I am unsure where I have gone wrong, any help is greatly appreciated!
Sub Better_Work_This_Time()
Dim FindString As String
Dim Rng As Range
ActiveCell = Sheets("Last Week").Range("A2").Activate
FindString = ActiveCell
Dim County As Integer
Count = Cells.CurrentRegion.rows.Count
For i = 2 To County
If Trim(FindString) <> "" Then
With Sheets("Current Week").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
ActiveCell.Font.Color = vbBlue
End If
End With
End If
If IsEmpty(FindString) Then
FindString = False
End If
ActiveCell.Offset(1, 0).Select
i = i + 1
Next
End Sub
Without using ActiveCell and using Match instead of Find.
Option Explicit
Sub Does_Work_This_Time()
Dim wb As Workbook, wsLast As Worksheet, wsCurrent As Worksheet
Dim FindString As String, ar, v
Dim LastRow As Long, i As Long, n As Long
Set wb = ThisWorkbook
' put current week values into array
Set wsCurrent = wb.Sheets("Current Week")
With wsCurrent
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A2:A" & LastRow).Value2
End With
' scan last week matching current week
Set wsLast = wb.Sheets("Last Week")
With wsLast
.Columns(1).Interior.Color = xlNone
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
FindString = Trim(.Cells(i, "A"))
If Len(FindString) > 0 Then
v = Application.Match(FindString, ar, 0)
If IsError(v) Then
'no match
ElseIf ar(v, 1) = FindString Then ' case match
.Cells(i, "A").Interior.Color = RGB(128, 255, 128) ' light green
n = n + 1
End If
End If
Next
End With
MsgBox n & " rows matched"
End Sub

How to distribute a known number evenly across a range in VBA

I've a problem here, I've been trying to use VBA to distribute a known number evenly across a range.The problem is that I need to find the way where the numbers in the range be as equal as possible to each other, could you help me? or give ideas?
The data set is as follow
The known number is given by "TV Comodin" Row in color Red, and here is my try:
Sub Prueba()
Columns("A:A").Select
Set Cell = Selection.Find(What:="TV Comodín", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ActiveCell = Cell
Cell.Select
comodin = ActiveCell.Offset(0, 1).Value2
Range("A2").Select
Firstrow = ActiveCell.Row
Selection.End(xlDown).Select
Lastrow = ActiveCell.Row
j = comodin
While (j > 0)
For i = 2 To Lastrow
Range("B2").Select
Range("B" & i) = Range("B" & i).Value + 1
If j > 0 Then j = j - 1
If j = 0 Then Exit For
Next
Wend
End Sub
Basically, my code finds the "TV Comodin" row to get de number of times that the loop is gonna add 1 by 1 in every single row of its column,
Sorry, I'm a little bit new on VBA, thanks by the way.
Here's one approach. Find the smallest number in the range: add one. Repeat until you've done that (eg) 55 times.
Sub Prueba()
Dim f As Range, ws As Worksheet, comodin As Long, rng As Range, m, mn
Set ws = ActiveSheet
Set rng = ws.Range("A2", ws.Range("A2").End(xlDown)).Offset(0, 1)
Set f = ws.Columns("A").Find(What:="TV Comodín", LookIn:=xlFormulas, _
LookAt:=xlWhole, MatchCase:=False)
If Not f Is Nothing Then
rng.Value = ws.Evaluate("=" & rng.Address() & "*1") 'fill empty cells with zeros
comodin = f.Offset(0, 1).Value
Do While comodin > 0
mn = Application.Min(rng)
If mn >= 100 Then Exit Do ' exit when no values are <100
m = Application.Match(mn, rng, 0)
rng.Cells(m).Value = rng.Cells(m).Value + 1
comodin = comodin - 1
Loop
Else
MsgBox "not found!"
End If
End Sub

Search for all values between 2 values in a column and loop till last one found

Lets start with I am self taught in Excel VBA and have a question that might seem stupid or basic:
I have the following information on a sheet:
[ConfBlastPlan]
DRB1065
PU1962;427;05_37_OB;A;2;2;1
PU1963;364;05_37_OB;B;2;2;1
PU1959;373;05_37_OB;C;2;2;1
-
[FiringProcedure]11:55:21;MULTI
What I want to do is combine all strings between with "PU" and the first ";" that is found between the
"[ConfBlastPlan]" and [FiringProcedure] into one cell.
I have read up about the loop function but seems I have confused myself terribly.
How do I loop this and combine the strings found?
I have started the function using the following code:
Sub DRBEquipNumberPU() 'GET THE PU#s
Dim WSFrom As Worksheet
Dim WSTo As Worksheet
Dim RngFrom As Range
Dim RngTo As Range
Dim BlastNumber As String
Dim BlastNumberStep As Long
Dim SearchString As String
Dim SearchStringStart As String
Dim SearchStringEnd As String
Dim LineStep As Long
Dim Blastedrng As Range
Dim BlastedFoundrng As Range
Dim closePos As Integer
BlastNumberStep = 1
LineStep = 1
Set Blastedrng = ThisWorkbook.Worksheets("Blast Summary Sheet").Range("A2", Range("A2").End(xlDown))
For Each BlastedFoundrng In Blastedrng.Cells
On Error Resume Next
SearchString = "[ConfBlastPlan]"
SearchStringStart = "PU"
SearchStringEnd = "[FiringProcedure]"
BlastNumber = CStr("Blasted " & BlastNumberStep)
Set WSFrom = Worksheets(CStr(BlastNumber))
Set RngFrom = WSFrom.Cells.Find(What:=SearchString, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set RngFrom1 = WSFrom.Cells.Find(What:=SearchStringStart, After:=RngFrom, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Set WSTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
Set RngTo = WSTo.Cells.Find(What:=(CStr(BlastNumber)), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
closePos = InStr(1, RngFrom.Cells.Value, ";")
If RngTo.Cells.Offset(0, 4).Value = "INCOMPLT" Then
RngTo.Cells.Offset(0, 7).Value = "INCOMPLT"
ElseIf RngFrom.Cells.Value Is Nothing Then
RngTo.Cells.Offset(0, 7).Value = "NO PU #s"
ElseIf RngFrom.Cells.Value Like SearchStringStart Then
RngTo.Cells.Offset(0, 7).Value = Mid(RngFrom.Cells.Value, 0, closePos)
ElseIf RngFrom.Cells.Value = SearchStringEnd Then
End If
BlastNumberStep = BlastNumberStep + 1
Next BlastedFoundrng
End Sub
All it returns at the moment is INCOMPL or NO PU #s
There can be a maximum of 48 instances of PU
Please help
Blasted 23:
Blasted 26:
Blasted 27:
Option Explicit
' Major changes: make it two steps-- 1)Get all Sheet names, 2)Process all Lines on one sheet
Sub StepThruBlastedSheetNames() 'GET THE PU#s
Dim WSSummary As Worksheet, rowSummary As Long
Set WSSummary = ThisWorkbook.Worksheets("Blast Summary Sheet")
rowSummary = 1
Dim WSFrom As Worksheet
For Each WSFrom In ThisWorkbook.Worksheets
If InStr(WSFrom.Name, "Blasted ") > 0 Then
StepThruBlastedLines WSSummary, rowSummary, WSFrom
End If
Next
End Sub
Sub StepThruBlastedLines(WSSummary As Worksheet, rowSummary As Long, WSFrom As Worksheet)
' these never change, ergo do not put inside loop
Const SearchStringStart As String = "[ConfBlastPlan]"
Const SearchStringFindPU As String = "PU"
Const SearchStringEnd As String = "[FiringProcedure]"
Dim rowFrom As Long
Dim rowMax As Long
rowMax = WSFrom.Cells(WSFrom.Rows.Count, "A").End(xlUp).Row
Dim IsBetween As String, PUlist As String, posSemi As Long, DRBname As String
IsBetween = "N"
PUlist = ""
DRBname = ""
For rowFrom = 1 To rowMax
If IsBetween = "Y" Then
If InStr(WSFrom.Cells(rowFrom, "A"), "DRB") > 0 Then
DRBname = WSFrom.Cells(rowFrom, "A")
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringFindPU) > 0 Then
posSemi = InStr(WSFrom.Cells(rowFrom, "A"), ";")
PUlist = PUlist & Mid(WSFrom.Cells(rowFrom, "A"), 1, posSemi)
End If
If InStr(WSFrom.Cells(rowFrom, "A"), SearchStringEnd) > 0 Then
IsBetween = "N"
rowSummary = rowSummary + 1
WSSummary.Cells(rowSummary, "A") = WSFrom.Name
WSSummary.Cells(rowSummary, "B") = DRBname
If PUlist <> "" Then
WSSummary.Cells(rowSummary, "C") = PUlist
PUlist = ""
Else
'<< add put empty notice
WSSummary.Cells(rowSummary, "C") = "INCOMPL"
End If
DRBname = "" '<<added
End If
ElseIf WSFrom.Cells(rowFrom, "A") = SearchStringStart Then
IsBetween = "Y"
End If
Next rowFrom
End Sub
Here's code that extracts the PU-values from a worksheet like the one you posted. I couldn't figure out why you called this worksheet WsTo and perhaps that's the reason why I also couldn't guess at your intention for what to do with the result. Your question is mute on the point. So I left the project at that point. I'm sure you will be able to pick it up from the two ways I'm displaying the Output array.
Sub DRBEquipNumberPU()
' 134
' Get the PU#s
Const Blast As String = "[ConfBlastPlan]"
Const BlastEnd As String = "-"
Const Marker As String = "PU"
Dim WsTo As Worksheet
Dim BlastFound As Range
Dim CellVal As String ' loop variable: Cell.Value
Dim R As Long ' loop counter: rows
Dim Output As Variant ' array of found values
Dim i As Long ' index to Output
Set WsTo = ThisWorkbook.Worksheets("Blast Summary Sheet")
With WsTo.Columns(1)
Set BlastFound = .Find(What:=Blast, _
LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=False)
If BlastFound Is Nothing Then
MsgBox """" & Blast & """ wasn't found.", _
vbInformation, "No data to process"
Else
ReDim Output(1 To 100) ' choose UBound larger than you ever need
R = BlastFound.Row
Do
R = R + 1
CellVal = .Cells(R).Value
If InStr(1, Trim(CellVal), Marker, vbTextCompare) = 1 Then
i = i + 1
Output(i) = CellVal
End If
Loop While Len(CellVal) And CellVal <> BlastEnd
If i Then
ReDim Preserve Output(1 To i)
MsgBox "Found values = " & vbCr & _
Join(Output, Chr(13))
For i = LBound(Output) To UBound(Output)
Debug.Print Output(i)
Next i
End If
End If
End With
End Sub
It just occurs to me that the end marker you suggested ("FiringProcedure]") may be more reliable than my choice ("-"). If so, just change it at the top of the code where the constants are declared. If that marker is missed the code might continue to include the "PU" line below the [Blasting Plan] row.

How to parse through a row using information pulled from a user form

I am attempting to create a userform which takes input from userform1 and passes it to userform2 which displays the information belonging to that set of data on userform2. The problem is that once the overall category is selected from row 1 (CATBOX), I need to limit the parser to the subcomponents in row 2 as there are other subcomponents in other categories on the same row. Each Category in row 1 is a series of merged cells.
I have already tried using 'find' to find the value of userform1!CATBOX and return the position to get the starting column. Then I tried to find the range of the merged cell so that I could get the end point. I then tried to limit the parser to the range of columns on row 2 to collect my information. I included the last bit of code to simply display the values of the start and end points onto userform2, it is not necessary to my code.
With ActiveSheet
Set ra = ActiveSheet.Cells.Find(What:=UserForm1!CATBOX.Value, After:=Range("A1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Set rng = Range(ra)
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
End If
Set rag = UserForm2.Controls.Add("Forms.Label.1", "rag", True)
With rag
.Caption = rngStart.Address
.Left = 10
.Width = 50
.Top = 50
End With
Set rag2 = UserForm2.Controls.Add("Forms.Label.1", "rag2", True)
With rag2
.Caption = rngEnd.Address
.Left = 70
.Width = 50
.Top = 50
End With
End With
The result I am looking to get is the ability to parse that second row of information limited to the range of columns established by the merged category above it.
Welcome to SO.Though the requirement and worksheet Data layout is not clear, It assumed as below.
Code used may be modified to your requirement and may be moved from Change Event of CATBOX to any suitable event
Private Sub CATBOX_Change()
Dim Rng As Range, SubRng As Range
Dim Rw As Long, ColSt As Long, ColEnd As Long, i As Long, ScatNo As Long
Dim Rag As Object
With ThisWorkbook.ActiveSheet
Set Rng = .Rows(1).Find(What:=UserForm1.CATBOX.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Rng Is Nothing Then Exit Sub
Set Rng = Rng.MergeArea
Set rngstart = Rng.Cells(1, 1)
Set rngEnd = Rng.Cells(Rng.Rows.Count, Rng.Columns.Count)
Rw = Rng.Row + Rng.Rows.Count
ColSt = Rng.Column
ColEnd = Rng.Column + Rng.Columns.Count - 1
Debug.Print Rw, ColSt, ColEnd
Set Rng = .Range(.Cells(Rw, ColSt), .Cells(Rw, ColEnd))
ScatNo = 0
For Each SubRng In Rng
If SubRng.Value <> "" Then
ScatNo = ScatNo + 1
Set Rag = UserForm2.Controls.Add("Forms.Label.1", "Scat" & ScatNo)
Rag.Caption = SubRng.Value
Rag.Left = 70
Rag.Width = 50
Rag.Top = ScatNo * 30
End If
Next
End With
UserForm2.Show
End Sub

EXCEL: highlighting reoccuring data in the same column

I have a column(D) of data in Excel that has been sorted using:
=TEXT(B2,"###").
This is to show a list of data (numberical) that has an additional "REP 1" against it.
Not all data has a "REP 1" in there, so I would like to highlight all fields which contain BOTH the number and the "REP 1".
I could highlight all "REP 1" fields, and see if there is a duplicate before it, but this is just a sample sheet. I have over 8,000+ fields to go through, and would be too time consuming.
Please see the below link for the example:
Required Formatting
I hope this all makes sense.
Thanks,
Tim.
Not sure if its possible to do with conditional formatting but this VBA code should work. Your Data wouldn't have to be sorted in any particular order, and assumes the data you are formatting is in column D. I've tested on a few 100 rows and it works fine, so should be fine with a large data set. Ive tried to explain what the code is doing through the comments in the code.
Sub formatCells()
Dim x As Variant
Dim y As Variant
Dim searchval As String
Dim a As Variant
Dim lastrow As Long
Dim rng As Range
Application.ScreenUpdating = False ' turn off screen updates
lastrow = Cells(Rows.Count, 4).End(xlUp).Row 'find the last blank cell
x = 2 'set rownumber
y = 4 'set columnnumber
While Cells(x, y) <> "" ' create loop
If InStr(Cells(x, y), "REP1") Then 'search for string in cell
Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell
End If
x = x + 1 ' loop
Wend ' end loop
x = 2 ' reset row number
y = 4 ' reset column number
While Cells(x, y) <> "" ' create loop 2
If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1
a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1
searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search
If searchval <> "" Then 'if theres a search value available run steps below
With Range("D1:D" & lastrow) 'set range to be column A
Set rng = .Find(What:=searchval, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then 'If search value is found
Application.Goto rng, True ' go to cell
ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red
End If
End With
End If
End If
x = x + 1 'loop 2
Wend ' end loop 2
End Sub
EDIT - Looks at column B not D
Sub formatCells()
Dim x As Variant
Dim y As Variant
Dim searchval As String
Dim a As Variant
Dim lastrow As Long
Dim rng As Range
Application.ScreenUpdating = False ' turn off screen updates
lastrow = Cells(Rows.Count, 2).End(xlUp).Row 'find the last blank cell
x = 2 'set rownumber
y = 2 'set columnnumber
While Cells(x, y) <> "" ' create loop
If InStr(Cells(x, y), "REP1") Then 'search for string in cell
Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell
End If
x = x + 1 ' loop
Wend ' end loop
x = 2 ' reset row number
y = 2 ' reset column number
While Cells(x, y) <> "" ' create loop 2
If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1
a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1
searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search
If searchval <> "" Then 'if theres a search value available run steps below
With Range("B1:B" & lastrow) 'set range to be column A
Set rng = .Find(What:=searchval, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then 'If search value is found
Application.Goto rng, True ' go to cell
ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red
End If
End With
End If
End If
x = x + 1 'loop 2
Wend ' end loop 2
End Sub

Resources