Loop not correctly deleting rows in the Worksheet - vba

So here is the task I am required to do.
I have a worksheet in which the user can specify a Column name and an element under the column, once chosen, the macro will find and delete every element with said name.
My issue comes from the final part of the macro, the delete. My loop doesn't delete all the rows, it will only find one instance of the element and delete it, then go to the next element and delete it, leaving every other element with the same name intact.
Here is the function within the macro, I apologize in advance for the poor code quality as I am not well versed in vba.
Function LineDelete() As Variant
Dim NbLignes As Integer
Dim ctr As Integer
Dim ctr2 As Integer
Dim Table As Variant
Worksheets("parametrage_suppr_ligne").Activate
ctr = 1
ctr2 = 1
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row - 4
ReDim Table(1 To NbLignes, 2)
While ctr <= NbLignes
Table(ctr, 1) = Cells(ctr + 4, 1).Value
Table(ctr2, 2) = Cells(ctr2 + 4, 2).Value
ctr = ctr + 1
ctr2 = ctr2 + 1
Wend
Call FileOpen
Call delInvalidChars
Call OrderRows
Dim newCtr As Integer
Dim rng As Range
Dim rngHeaders As Range
Dim newString As Variant
Dim i As Integer
NbLignes = 0
NbLignes = Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
Set rngHeaders = Range("1:1")
newCtr = 1
For i = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
newCtr= newCtr + 1
End If
End If
newCtr = newCtr + 1
Next i
End Function
So now to explain a bit what I've done here.
At first I store the options in a 2 dimentional table with a simple loop, in this table I store the name of the column a well as the name of the element under the column that has to be deleted.
After that I call the functions which open a txt file which is then transformed into an excel file, it is in this new excel file that the deletes have to be done.
I then reset the NbLignes variable as well as call new variables.
Here is where the issues begin, I thought that by iterating on the number of lines the new excel file has; the program was going to look for all of the instances of the word in the column and was going to delete them, but so far it will only do it 3 times.
I am totally lost as to what modify to be able to fix this.
Here is what the config table looks like, this is what the user can modify to specify what to delete, it is also what I store inside of the 2d Table:
User can add as many columns and names as needed
EDIT: What the code does now after updating is that it deletes all the elements that have the same name as the first one in the image (fun_h_opcomp), the expected outcome would be that as soon as all those elements are deleted, the program should then pass on to the next one (fun_b_pterm) and so on.

Of course the i was just an Example for that counter and you must use your newCtr counter here, and FirstRow must be set to a value.
Const FirstRow As Long = 1
Dim newCtr As Long 'always use Long for row counting
For newCtr = NbLignes To FirstRow Step -1
Set rng = rngHeaders.Find(Table(newCtr, 1))
If Table(newCtr, 1) = rng Then
MsgBox "All is gud!!"
newString = Cells.Find(Table(newCtr, 2))
If Table(newCtr, 2) = newString Then
MsgBox newString
Range(Cells.Find(Table(newCtr, 2)).Address).EntireRow.Delete
End If
End If
Next newCtr
There is no need to increment/decrement newCtr anymore because this is automatically done by the Next statement.

Related

Making an Associative Table of Unique Identifiers

I'm trying to create an associative table on a sheet that is pulling in data from a different sheet. By associative I mean, if the data is changed in the source data sheet, it would be reflected on the new sheet. I also want to only have the new sheet's table to be contingent on having a certain unique value. In my case, I want to pull up information related to a part number. The original source data will have many rows that contain the same part number, but I only care to display one of them.
This is what I have so far:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Dim ref() As Variant
Dim row As Integer
row = 92
Worksheets("Part Tracking Scorecard").Activate
While Cells(row, 6).Value:
If IsInArray(Cells(row, 6).Value, ref) Then
row = row + 1
ElseIf Not IsInArray(Cells(row, 6).Value, ref) Then
ReDim Preserve ref(1 To UBound(ref) + 1) As Variant
ref(UBound(ref)) = Cells(row, 6).Value
Worksheets("Unique Parts").Activate
?????
row = row + 1
To satisfy my condition to only showcase the unique part numbers, I initialized an empty array called "ref". Then, as I iterate through the source sheet, I would check if the part number was in ref with the function "IsInArray". If it was in it, it would move onto the next row, if it wasn't add the part number into the empty array and move to the next row.
The portion with the "????" is where I'm having most of my issue trying to figure out. That part is supposed to be where I make the new table with the date from the unique part number. The very simple and tedious thing I could do is make some loop to run through the columns of the rows and put in a vlookup function. I was wondering if there may be a more robust or more elegant way in doing this.
You've had the right reflex tyring to define an array to stock your values. Here are a few tips of how I would get around to doing it (not perfect, but it should help you out):
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Dim Source as Worksheets
Set Source = Worksheets("Part Tracking Scoreboard")
Dim ref1(), ref2() As Variant
Dim row, index, index2 As Integer
row = 92
ref1 = Source.Range(Worksheets(Source.Cells(row,1), Source.Cells(lastrow, last column))
'Start by placing your ENTIRE source sheet in ref1, if your source sheet is big, this will help you win A LOT of time during the looping phase. Notice how I start from row 92 seeing as this is where you started your loop
'lastrow and lastcolumn represent the position of the last cell in your source file
For index = row to lastrow
If Not IsInArray(ref1(row, 6).Value, ref2) Then
ref2(index) = ref1(index) 'copy the entire row from source to ref2
Next index
Dim NewFile as Worksheet
Set Newfile = Sheets("NewSheetName")
Dim ref2dimension_x, ref2dimension_y as Integer 'find dimensions of ref2 array
ref2dimension_x= UBound(ref2, 1) - LBound(ref2, 1) + 1
ref2dimension_y = UBound(ref2, 2) - LBound(ref2, 2) + 1
For index = 2 to ref2dimension_x 'go through entire new sheet and set values
For index2 = 1 to ref2dimension_y
NewFile.Cells(index, index2).Value = ref2(index - 1, index2)
Next index2
Next index
ref1() = nothing
ref2() = nothing 'free up the space occupied by these arrays
I was not sure about what you were trying to do exactly during the else loop. If you intention is to copy the entire row, this should work. If you want to copy only specific data from the source sheet, you will need to find the indexes of the corresponding columns (hardcode them if they are not going to budge, or use a loop to find them through string comparison otherwise).
This solution combines some macros that I use frequently (so even if you don't use them now, they might be helpful in the future). It won't work if the data in the unique table needs to be "live", but if it'd be sufficient for it to be updated whenever the workbook is opened/closed (or on demand), this is a lot less complicated than the array version.
Basically you just:
Copy the main/unduplicated table to a new sheet
Remove duplicates by part number
Remove unnecessary columns from unduplicated table (if applicable)
I'm assuming that your source data is in a formal Excel Table (ListObject). Just swap out "PartTable" for whatever your actual table is called.
Sub makeUniqueTable()
Application.ScreenUpdating = False
Dim MainWS As Worksheet
Set MainWS = ThisWorkbook.Sheets("Part Tracking Scorecard")
Dim UniqueWS As Worksheet
Set UniqueWS = ThisWorkbook.Sheets("Unique Parts")
UniqueWS.Cells.Clear
Call cloneTable(MainWS.ListObjects("PartTable"), "UniquePartTable", UniqueWS)
Dim UniquePartTable As ListObject
Set UniquePartTable = UniqueWS.ListObjects("UniquePartTable")
Call removeDuplicates(UniquePartTable, "Part Number")
'Optional: remove unnecessary columns by listing columns to be deleted...
'Call deleteColumns(UniquePartTable, Array("Unnecessary Column 1", "Unnecessary Column 2"))
'...or kept:
'Call deleteColumns(UniquePartTable, Array("Part Number", "Manufacturer", "Product Description"), True)
Application.ScreenUpdating = True
End Sub
Sub cloneTable(tbl As ListObject, newName As String, Optional newWS As Worksheet = Nothing)
'Copies a table (tbl) to a new worksheet (newWS) and gives it a name (newName)
'If there is any data in newWS, the new table will be added to the right of the used range
'If newWS is omitted, new table will be added to same worksheet as original table
Dim ws As Worksheet
Dim lastColumn As Long
Dim newRng As Range
Dim newTbl As ListObject
If newWS Is Nothing Then
Set ws = tbl.Parent
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set newRng = ws.Range(ws.Cells(1, lastColumn + 2), ws.Cells(1 + tbl.ListRows.Count, lastColumn + tbl.ListColumns.Count + 1))
Else
Set ws = newWS
If ws.ListObjects.Count > 0 Then
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set newRng = ws.Range(ws.Cells(1, lastColumn + 2), ws.Cells(1 + tbl.ListRows.Count, lastColumn + tbl.ListColumns.Count + 1))
Else
Set newRng = ws.Range(ws.Cells(1, 1), ws.Cells(1 + tbl.ListRows.Count, tbl.ListColumns.Count))
End If
End If
tbl.Range.Copy
newRng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set newTbl = ws.ListObjects.Add(xlSrcRange, newRng, , xlYes)
newTbl.Name = newName
End Sub
Sub removeDuplicates(tbl As ListObject, Optional colName As Variant = "")
'Removes duplicates from a table (tbl) based on column header names (colName()) provided by user
'If no column names are provided, duplicates will be removed based on all columns in table
Dim i As Long
Dim j As Long
If Not IsArray(colName) Then
If colName = "" Then
ReDim colNumArr(0 To tbl.ListColumns.Count - 1) As Variant
For i = 0 To tbl.ListColumns.Count - 1
colNumArr(i) = tbl.ListColumns(i + 1).Range.Column
Next
Else
ReDim colNumArr(0 To 0) As Variant
colNumArr(0) = tbl.ListColumns(colName).Range.Column
End If
Else
ReDim colNumArr(0 To UBound(colName) - LBound(colName)) As Variant
j = 0
For i = LBound(colName) To UBound(colName)
colNumArr(j) = tbl.ListColumns(colName(i)).Range.Column
j = j + 1
Next
End If
tbl.Range.removeDuplicates Columns:=(colNumArr), Header:=xlYes
End Sub
Sub deleteColumns(tbl As ListObject, ByVal colName As Variant, Optional invert As Boolean = False, Optional sheetCol As Boolean = True)
'Deletes column(s) from sheet based on header names (colName) from a table (tbl)
'Will result in error if provided column contains multiple tables
'colName can be a String or an array of Strings
'Inverted mode deletes all columns *except* those in colName
Dim i As Long
Dim j As Long
Dim x As Boolean
If Not IsArray(colName) Then
tempStr = colName
ReDim colName(1 To 1) As String
colName(1) = tempStr
End If
If invert = False Then
For i = LBound(colName) To UBound(colName)
If sheetCol = True Then
tbl.Parent.Columns(tbl.ListColumns(colName(i)).Range.Column).Delete
Else
tbl.ListColumns(colName(i)).Delete
End If
Next
Else
For i = tbl.ListColumns.Count To 1 Step -1
x = False
For j = LBound(colName) To UBound(colName)
If tbl.HeaderRowRange(i).Value = colName(j) Then
x = True
Exit For
End If
Next
If x = False Then
If sheetCol = True Then
tbl.Parent.Columns(tbl.ListColumns(i).Range.Column).Delete
Else
tbl.ListColumns(i).Delete
End If
End If
Next
End If
End Sub

Gather data tidy in Excel using VBA

What the case is:
So I got a "results sample" in excel format that needs filtering and reshaping to look nice. It is a result that will be not identical all the time but it follows similar rules. I have to filter it further and make it a little more tidy. I have figured out the filtering part, but I am not sure how to sort the remaining data, in a tidy way.
What the situation is:
There are six columns involved.
Notice: Real deal is not THAT simple, but what I need can be demonstrated using such a simple example and then I can manage more complex stuff myself I suppose.
For our example we use columns from B to G
The data are set as pairs of a "title" and a value.
For instance, if you look the first example picture I provide, The first detais the pair B3 and C3.
As you can see, looking at the same picture, D3 and E3 is an empty pair.
Same goes for D4 - E4 and F4 - G4 and so on until a last one at B11 - C11.
Starting data example:
[
What I want to achieve:
I would like, using Visual Basic for Applications, to sort the data, starting from let's say for our example B3 (see second picture) and fill three SETS of two columns, (BC, DE, FG) if there are no data inside those cells.
Notice: If a cell like D3 is null then SURELY E3 will be null too so there can be just only one check. I mean we can check either value columns or title columns.
Notice2: The B,D,F or C,E,G columns DON'T have to be sorted. I just want all the not-null values of B,D,F and their respective values from C,E,G gathered together neat so printing will not need 30 pages but just a few (too many spaces between is causing it and I try to automate the cleanup)
Here's something to start with. The first double loop populates a VBA Collection with Range variables that refer to the Cells that contain the titles.
The associated values are obtained by using an offset. The middle double loop performs a bubble sort on the latter (highly inefficient - you might want to replace it with something else). The next if statement creates a 2nd sheet if it doesn't exist on which to write out the results (last loop).
Option Explicit
Sub GatherData()
Dim lastRow As Integer, lastCol As Integer
Dim r As Integer, c As Integer
Dim vals As Collection
Set vals = New Collection
With Sheets(1)
lastCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column
lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).row
For c = 1 To lastCol Step 2
For r = 1 To lastRow
If (Trim(Cells(r, c).Value) <> "") Then
vals.Add .Cells(r, c)
End If
Next
Next
End With
' Bubble Sort
Dim i As Integer, j As Integer
Dim vTemp As Range
For i = 1 To vals.Count - 1
For j = i + 1 To vals.Count
If vals(i).Value > vals(j).Value Then
Set vTemp = vals(j)
vals.Remove j
vals.Add vTemp, vTemp, i
End If
Next j
Next i
Dim sht2 As Worksheet
If ThisWorkbook.Worksheets.Count = 1 Then
Set sht2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(1))
Else
Set sht2 = Worksheets(2)
End If
With sht2
r = 3
c = 2
For i = 1 To vals.Count
.Cells(r, c).Value = vals(i).Value
.Cells(r, c + 1).Value = vals(i).Offset(, 1).Value
c = c + 2
If c = 8 Then
r = r + 1
c = 2
End If
Next
End With
End Sub
Here is a method using the Dictionary object. I use early binding which requires setting a reference to Microsoft Scripting Runtime. If you are going to be distributing this, you might want to convert this to late-binding.
We assume that your data is properly formed as you show it above. In other words, all the titles are in even numbered columns; and the results are in the adjacent cell.
We create the dictionary using the Title as the Key, and the adjacent cell value for the Dictionary item.
We collect the information
Transfer the Keys to a VBA array and sort alphabetically
create a "Results Array" and populate it in order
write the results to a worksheet.
I will leave formatting and header generation to you.
By the way, there is a constant in the code for the number of Title/Value pair columns. I have set it to 3, but you can vary that.
Enjoy
Option Explicit
Option Compare Text 'If you want the sorting to be case INsensitive
'set reference to Microsoft Scripting Runtime
Sub TidyData()
'Assume Titles are in even numbered columns
'Assume want ColPairs pairs of columns for output
'Use dictionary with Title as key, and Value as the item
Dim dctTidy As Dictionary
Dim arrKeys As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V As Variant
'in Results
Const ColPairs As Long = 3
'Set Source and results worksheet and range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 2)
'Read source data into variant array
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Collect the data into a dictionary
Set dctTidy = New Dictionary
For I = 1 To UBound(vSrc, 1)
For J = 2 To UBound(vSrc, 2) Step 2
If vSrc(I, J) <> "" Then _
dctTidy.Add Key:=vSrc(I, J), Item:=vSrc(I, J + 1)
Next J
Next I
'For this purpose, we can do a simple sort on the dictionary keys,
' and then create our results array in the sorted order.
arrKeys = dctTidy.Keys
Quick_Sort arrKeys, LBound(arrKeys), UBound(arrKeys)
'Create results array
ReDim vRes(1 To WorksheetFunction.RoundUp(dctTidy.Count / ColPairs, 0), 1 To ColPairs * 2)
I = 0
J = 0
For Each V In arrKeys
K = Int(I / ColPairs) + 1
L = (J Mod ColPairs) * 2 + 1
vRes(K, L) = V
vRes(K, L + 1) = dctTidy(V)
I = I + 1
J = J + 1
Next V
'write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Worksheet.Cells.Clear
.Value = vRes
.HorizontalAlignment = xlCenter
End With
End Sub
Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = first
High = last
List_Separator = SortArray((first + last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (first < High) Then Quick_Sort SortArray, first, High
If (Low < last) Then Quick_Sort SortArray, Low, last
End Sub
Assuming we got all variables set and initialized properly, in this example:
Sheets("sheetname").Select ' because stupid things can happen...
For i = 3 To 13
Let newrangeT = "B" & i '
Let newrangeV = "C" & i '
If Sheets("sheetname").Range(newrangeV) <> "" Then
values(Position) = Sheets("sheetname").Range(newrangeV)
titles(Position) = Sheets("sheetname").Range(newrangeT)
Position = Position + 1
Else
' Don't do anything if the fields are null
End If
Next i
Sheets("sheetname").Range("B1:G13").Clear
' We then get each data from the arrays with a For loop.
' We set a columnset variable to 1.
' We set a currentrow variable to 3.
' If columnset is 1 data will enter in B and C and columnset = columnset +1
' Then if columnset is 2 we set data to DE and columnset = columnset +1
' But if columnset is 2we set data to FG and columnset = 1 and currentrow = currentrow +1
' Iterating the arrays will result in a neat setting of the data, but it will add zeros for all the nulls. Thus we need an If statement that will exclude that values checking the TITLE array (that should contain a title instead). if the value is not 0 then... we run what I describe, otherwise we do nothing.
Putting the data in the array is half of the trick.
Then we clear the area.
We set two string variables to declare ranges (actually cell reference) for every cell iterated in the loop. Here I demonstrated only for column set B,C
but we have to do the same for the rest of the columns.
The If statement here checks for null. You might have different needs, so changing the if statement changes the filtering. Here I check if the cells are not null. If the cells of column C contain data, put those data in values array and the respective B data on titles array but where? Position starts as 1 and we then iterate it +1 each time it adds something.
You can set data from an array using this command:
' current_row is set to the first row of the spreadsheet we wanna fill.
Sheets("sheetname").Select ' because stupid things can happen...
newrangeV = "C" & current_row
Sheets("sheetname").Range(newrangeV) = values(j)
The rest is just putting things together.
In any case, I wanna thank both of the people involved in this question, because I might didn't got the solution, but I got an idea of how to do other stuff, like accidentally learning something new. Cheers.

Automatic Grouping Excel VBA

This Question has been answered, however I need help with one point. I am using the code provided in the answer, however I can not get the subgrouping, for the entirety of the document. Is such thing possible?
Section Index
1 1
+ 1.1 2
++ 1.1.1 3
+++1.1.1.1 4
+++1.1.1.2 4
+++1.1.1.3 4
++ 1.1.2 3
++ 1.1.3 3
+ 1.2 2
+ 1.3 2
2 1
NOTE: Plusses shows groups.
I have such table as above, where I have indexed the sections with sublevels. I am trying to group those section using excel group feature, however, I have over 3000 rows of data, so I am trying to automate the process. I have modified a Excel VBA macro I found here and got this code below.
Sub AutoGroupBOM()
'Define Variables
Dim StartCell As Range 'This defines the highest level of assembly, usually 1, and must be the top leftmost cell of concern for outlining, its our starting point for grouping'
Dim StartRow As Integer 'This defines the starting row to beging grouping, based on the row we define from StartCell'
Dim LevelCol As Integer 'This is the column that defines the assembly level we're basing our grouping on'
Dim LastRow As Integer 'This is the last row in the sheet that contains information we're grouping'
Dim CurrentLevel As Integer 'iterative counter'
Dim groupBegin, groupEnd As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Application.ScreenUpdating = False 'Turns off screen updating while running.
'Prompts user to select the starting row. It MUST be the highest level of assembly and also the top left cell of the range you want to group/outline"
Set StartCell = Application.InputBox("Select levels' column top cell", Type:=8)
StartRow = StartCell.Row
LevelCol = StartCell.Column
LastRow = ActiveSheet.UsedRange.End(xlDown).Row 'empty rows above aren't included in UsedRange.rows.count => UsedRange.End
'Remove any pre-existing outlining on worksheet, or you're gonna have 99 problems and an outline ain't 1
Cells.ClearOutline
'Walk down the bom lines and group items until you reach the end of populated cells in the assembly level column
groupBegin = StartRow + 1 'For the first group
For i = StartRow To LastRow
CurrentLevel = Cells(i, LevelCol)
groupBegin = i + 1
'Goes down until the entire subrange is selected according to the index
For n = i + 1 To LastRow
If Cells(i, LevelCol).Value = Cells(n, LevelCol).Value Then
If n - i = 1 Then
Exit For
Else
groupEnd = n - 1
Rows(groupBegin & ":" & groupEnd).Select
'If is here to prevent grouping level that have only one row
End If
Exit For
Else
End If
Next n
Next i
'For last group
Rows(groupBegin & ":" & LastRow).Select
Selection.Rows.Group
ActiveSheet.Outline.ShowLevels RowLevels:=1 'Minimize all the groups
ActiveSheet.Outline.SummaryRow = xlAbove 'Put "+" next to first line of each group instead of the bottom
Application.ScreenUpdating = True 'Turns on screen updating when done.
End Sub
Basically what I am trying to do in the above code is to select the top index and run down the cells until that index is the same value again. Basically for the example chart, I would like to select rows(2:4) and group them. This is not achieved by the code. Also, code skips grouping if the adjacent rows are with the same index.
Is this a viable method or should I re-think my loops and how?
The code you have arrived at seems a little convoluted to me. Change to your needs and try this:
Sub groupTest()
Dim sRng As Range, eRng As Range ' Start range, end range
Dim rng As Range
Dim currRng As Range
Set currRng = Range("B1")
Do While currRng.Value <> ""
Debug.Print currRng.Address
If sRng Is Nothing Then
' If start-range is empty, set start-range to current range
Set sRng = currRng
Else
' Start-range not empty
' If current range and start range match, we've reached the same index & need to terminate
If currRng.Value <> sRng.Value Then
Set eRng = currRng
End If
If currRng.Value = sRng.Value Or currRng.Offset(1).Value = "" Then
Set rng = Range(sRng.Offset(1), eRng)
rng.EntireRow.Group
Set sRng = currRng
Set eRng = Nothing
End If
End If
Set currRng = currRng.Offset(1)
Loop
End Sub
Note that there is no error-handling here, the code is a little verbose for readability and bonus - no select.
Edit:
As requested, the subgrouping. This actually had me stuck for a bit - I coded myself into a corner and only barely got out on my own!
A few notes:
I have tested this to some extent (with 4 sublevels and multiple parents) and it works nicely. I tried to write the code so that you can have as many sublevels or as many parents as you want. But it has not been extensively tested, so I couldn't guarantee anything.
However, for some scenarios, Excel won't properly display the +-signs, I am guessing that is due to lack of space in these particular scenarios. If you encounter this, you can contract and expand the different levels using the numbered buttons at the top of the column the +-signs are located in. This will expand/contract all groups of that particular sub-level, however, so it is not optimal. But it is what it is.
Assuming a setup like this (this is after the grouping - you can see the missing +-signs here, for example for group 1.3 and 3.1 -- but they are grouped!):
Sub subGroupTest()
Dim sRng As Range, eRng As Range
Dim groupMap() As Variant
Dim subGrp As Integer, i As Integer, j As Integer
Dim startRow As Range, lastRow As Range
Dim startGrp As Range, lastGrp As Range
ReDim groupMap(1 To 2, 1 To 1)
subGrp = 0
i = 0
Set startRow = Range("A1")
' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
Do While (startRow.Offset(i).Value <> "")
groupMap(1, i + 1) = startRow.Offset(i).Address
groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
ReDim Preserve groupMap(1 To 2, 1 To (i + 2))
Set lastRow = Range(groupMap(1, i + 1))
i = i + 1
Loop
' Destroy already existing groups, otherwise we get errors
On Error Resume Next
For k = 1 To 10
Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
Next k
On Error GoTo 0
' Create the groups
' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
Do While (subGrp > 0)
For j = LBound(groupMap, 2) To UBound(groupMap, 2)
If groupMap(2, j) >= CStr(subGrp) Then
' If current value in the map matches the current group index
' Update group range references
If startGrp Is Nothing Then
Set startGrp = Range(groupMap(1, j))
End If
Set lastGrp = Range(groupMap(1, j))
Else
' If/when we reach this loop, it means we've reached the end of a subgroup
' Create the group we found in the previous loops
If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group
' Then, reset the group ranges so they're ready for the next group we encounter
If Not startGrp Is Nothing Then Set startGrp = Nothing
If Not lastGrp Is Nothing Then Set lastGrp = Nothing
End If
Next j
' Decrement the index
subGrp = subGrp - 1
Loop
End Sub
The subGroupTest() function above can be replaced by 6 lines of code:
Sub subGroupTest()
Dim cRng As range
Set cRng = range("A1")
Do While cRng.Value <> ""
cRng.EntireRow.OutlineLevel = UBound(Split(cRng.Value, ".")) + 1
Set cRng = cRng.Offset(1)
Loop
End Sub
Consecutive rows on the same OutlineLevel are automatically grouped together, so no need to jump through all the hoops in order to solve for the depths manually. OutlineLevel = 1 means the row is not grouped too.
As a bonus, there is no need to delete the outline levels beforehand.

COUNTIF() in 'For' loop

I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub

List column numbers if columns contain string

I have some code that searches for the string "dog" in sheet1 of a workbook, the string can appear many times in the sheet, and it gives me a vector of the column numbers if the string was found in those columns, (dog can only appear once in each column). I have a button on the sheet which I assign this macro:
Option Explicit
Sub mymacro2()
Dim dog() As Integer
Dim coldog As Range
Set coldog = Sheets(1).UsedRange.Find("dog", , xlValues, xlWhole)
Dim i As Integer
i = 0
ReDim dog(0)
dog(i) = coldog.Column
Do
i = i + 1
ReDim Preserve dog(i)
Set coldog = Sheets(1).UsedRange.FindNext(coldog)
dog(i) = coldog.Column
Loop While dog(i) <> dog(0)
ReDim Preserve dog(i - 1)
Sheets(1).Cells(1, 1).Resize(1, UBound(Application.Transpose(dog))) = dog
'above line is displaying the vector on the sheet for testing purposes
Set coldog = Nothing
ReDim dog(0)
End Sub
The macro gives me the vector I want, i.e. it tells me in which columns I can find the string "dog".
Now, I want to modify the code or create a whole new code that does the same thing for each string in a list of strings found in column 1 on sheet2. All the vectors with the column numbers has to have the same name as the string it has column information about. Like I do manually in the code above.
The point is I have a list of about 130 animals which I need to do the same thing for. What is the best way of doing that in Excel VBA?
You have to store all the animals in another Array and call the given actions for each of them. Also your code has quite a few redundant parts. The sample code below should give you a good grasp to understand how to face this problem (as said via comment by Mehow, we are not here to write codes for you).
Dim totAnimals As Integer, i As Integer
totAnimals = 3
ReDim animals(totAnimals - 1) As String
animals(0) = "dog"
animals(1) = "cat"
animals(2) = "mouse"
'etc.
maxMatches = 100 'Maximum number of matches per animal. better don't make this value too big
ReDim matchCount(totAnimals - 1) 'This counter goes from 1 to maxMatches
ReDim matchCols(totAnimals - 1, maxMatches) As Integer
Dim targetRange As Range, tempRange As Range, tempRange2 As Range
Set targetRange = Sheets("sheet2").Columns(1)
For i = 0 To totAnimals - 1
Set tempRange = targetRange.Find(animals(i), , xlValues, xlWhole)
If (Not tempRange Is Nothing) Then
If (matchCount(i) + 1 <= maxMatches) Then
matchCount(i) = matchCount(i) + 1
matchCols(i, matchCount(i)) = tempRange.Column
Dim startAddress As String: startAddress = tempRange.Address
Set tempRange2 = tempRange
Do
Set tempRange2 = targetRange.FindNext(tempRange2)
If (Not tempRange2 Is Nothing) Then
If (tempRange2.Address = startAddress) Then Exit Do
Else
Exit Do
End If
If (matchCount(i) + 1 > maxMatches) Then Exit Do
matchCount(i) = matchCount(i) + 1
matchCols(i, matchCount(i)) = tempRange2.Column
Loop While (Not tempRange2 Is Nothing)
End If
End If
Next i