I am trying to make a macro that will automatically group (collapse) all rows when the text in column A is not in bold. I do not have any code yet, however when I have done it before based on cell color, code taken from here, it has not worked based on the solution provided. Any help will be greatly appreciated.
Rows as they appear
Rows when they are grouped, which I have done manually.
I updated the code you referenced to check the Range.Font.Bold property. This code assumes A as the column with bold values.
Sub RowGrouper()
Dim rng As Range
Dim lastRow As Long
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For Each rng In Range(Cells(1, 1), Cells(lastRow, 1)).Cells
If rng.Font.Bold Then
rng.Rows.Group
End If
Next
End Sub
Just read your additional info on Conditional Formatting.
So, in that case you can simply use the DisplayFormat method and run the same method.
Sub SetGroups()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range, pCell As Range
'Dim dict As Scripting.Dictionary => use if adding the reference 'Microsoft Scripting Runtime'
'Set dict = New Scripting.Dictionary
Dim dict As Object '=> use when NOT adding the reference 'Microsoft Scripting Runtime'
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
Set rng = ws.UsedRange
'Set grouping button to top row
With ws.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
For Each cell In rng.Cells
If pCell Is Nothing Then
Set pCell = cell
End If
'If cell.Font.Bold And Not dict.Exists(cell.row) Then
If cell.DisplayFormat.Font.Bold And Not dict.Exists(cell.row) Then
dict.Add cell.row, cell.row
Set pCell = cell
End If
If dict.Exists(pCell.row) Then
dict.Item(pCell.row) = cell.row
End If
Next
'ungroup all used rows
rng.Rows.ClearOutline
For Each Key In dict.Keys
If (dict(Key) > Key) Then
Range(Rows(Key + 1), Rows(dict(Key))).Rows.Group
End If
Next
End Sub
Related
So here's the code. I have a calendar with dates in B4:H9. I want to change the color of the cells if the those dates are in a list (column, on different worksheet).
This might be a bit heavy to run if there are many different dates in the worksheet, but that doesn't matter.
What am I doing wrong here? It keeps giving me different error codes, when trying different things.
Sub check_Click()
Dim area As Range
Dim item1 As Range
Dim item2 As Range
Dim sheet As Worksheet
Dim columnlist As Range
sheet = Range("E2").Value
area = Range("B4:H9")
columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
For Each item1 In area
For Each item2 In columnlist
If item1.Value = item2.Value Then
item1.Interior.ColorIndex = RGB(255, 255, 0)
End If
Next item2
Next item1
End Sub
As SuperSymmetry mentioned, when you define objects (e.g. ranges, sheets) you need to use the Set keyword. I will not get into that explanation. However few things that I would like to mention...
Try and give meaningful variable names so that you can understand what are they for.
Work with objects so that your code knows which sheet, which range are you referring to.
No need of 2nd loop. Use .Find to search for your data. It will be much faster
To set RGB, you need .Color and not .ColorIndex
Is this what you are trying? (Untested)
Option Explicit
Sub Check_Click()
Dim rngData As Range
Dim rngReference As Range
Dim aCell As Range
Dim matchedCell As Range
Dim ws As Worksheet
Dim lastRow As Long
Dim worksheetName As String
'~~> Change the sheet name accordingly
worksheetName = ThisWorkbook.Sheets("Sheet1").Range("E2").Value
Set ws = ThisWorkbook.Sheets(worksheetName)
With ws
'~~> Find the last row in Col A
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngData = .Range("B4:H9")
Set rngReference = .Range("A2:A" & lastRow)
'~~> Loop through your data and use .Find to check if the date is present
For Each aCell In rngData
Set matchedCell = rngReference.Find(What:=aCell.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not matchedCell Is Nothing Then
'~~> Color the cell
matchedCell.Interior.Color = RGB(255, 255, 0)
End If
Next aCell
End With
End Sub
This should do the trick, I don't like leaving ranges without their sheet, but since I believe you are using a button, there should be no problem:
Option Explicit
Sub check_Click()
'We are going to use a dictionary, for it to work you need to:
'Go to Tools-References-Check the one called: Microsoft Scripting Runtime
Dim DatesToChange As Dictionary: Set DatesToChange = LoadDates
Dim area As Range: Set area = Range("B4:H9")
Dim item As Range
For Each item In area
If DatesToChange.Exists(item.Value) Then
item.Interior.Color = RGB(255, 255, 0)
End If
Next item
End Sub
Private Function LoadDates() As Dictionary
Set LoadDates = New Dictionary
Dim arr As Variant: arr = ThisWorkbook.Sheets(Range("E2")).Range("A:A")
Dim i As Long
For i = 2 To UBound(arr)
'This here will break the loop when finding an empty cell in column A
If arr(i, 1) = vbNullString Then Exit For
'This will add all your dates in a dictionary (avoiding duplicates)
If Not LoadDates.Exists(arr(i, 1)) Then LoadDates.Add arr(i, 1), 1
Next i
End Function
When you define objects (e.g. ranges, sheets) you need to use the Set keyword
Set area = Range("B4:H9")
Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
Worksheets() accepts either an Integer or a String. Therefore, sheet should be of Type String
Dim sheet As String
You're also setting columnlist to the whole column in the sheet so you're looping hundreds of thousands more times unncessarily. Change it to
With Worksheets(sheet)
Set columnlist = .Range(.Range("A2"), .Range("A" & Rows.Count).Offset(xlUp))
End With
The above should fix the errors in your code and make it run a little faster. However, there's still big room for improvment in the efficiency of the code. For example, instead of changing the colour inside the loop, you should build a range and set the colour one time after the loop.
Also consider resetting the colour at the beginning of the code with
area.Interior.Pattern = xlNone
I would personally go with conditional formatting as #SiddharthRout suggested in the comments.
Edit following comment
Here's my rendition
Sub check_Click()
Dim dStart As Double
dStart = Timer
Dim rngCalendar As Range
Dim vCalendar As Variant
Dim shtDates As Worksheet
Dim vDates As Variant, v As Variant
Dim i As Long, j As Long
Dim rngToColour As Range
' Change the sheet name
With ThisWorkbook.Sheets("Calendar")
Set rngCalendar = .Range("B4:H9")
vCalendar = rngCalendar.Value
Set shtDates = ThisWorkbook.Sheets(.Range("E2").Value)
End With
With shtDates
vDates = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(vCalendar, 1)
For j = 1 To UBound(vCalendar, 2)
For Each v In vDates
If v <> vbNullString And v = vCalendar(i, j) Then
If rngToColour Is Nothing Then
Set rngToColour = rngCalendar.Cells(i, j)
Else
Set rngToColour = Union(rngToColour, rngCalendar.Cells(i, j))
End If
Exit For
End If
Next v
Next j
Next i
rngCalendar.Interior.Pattern = xlNone
If Not rngToColour Is Nothing Then
rngToColour.Interior.Color = RGB(255, 255, 0)
End If
MsgBox "Time taken: " & Format(Timer - dStart, "0.0000s")
End Sub
With a list of 2500 dates it took 0.0742s on my machine.
I use VBA rarely and am always re-learning. This is my first posting.
I am using OCR to pull in tables from PDFs to individual worksheets (usually 100-200 tabs) and I have VBA programming ready to consolidate the data based on header values. But the headers are error prone and need to be reviewed first. I want to run a VBA macro that tests headers in row 1 against a set list and highlight those headers that exactly match.
I found a great start with Conditional formatting over huge range in excel, using VBA (Dictionary Approach) which tests lists, but I am struggling to convert the code to handle rows instead of columns. (Next I plan to have it run on every tab in the workbook, but am stuck at the testing stage).
Here is my current edit of the original code to pull from rows, but I get a subscript out of range on If dict2.Exists(vals(i)) Then
Option Explicit
Sub main3()
Dim mainRng As Range, list1Rng As Range
Dim mainDict As New Scripting.Dictionary, list1Dict As New
Scripting.Dictionary 'Main is Header and list1 is prescribed header list
Set mainRng = GetRange(Worksheets("Main"), "1") '<--| get "Main" sheet row "1" range from column A right to last non empty column
Set list1Rng = GetRange(Worksheets("list1"), "1") '<--| get "list1" sheet row "1" range from column A right to last non empty column
Set mainDict = GetDictionary(mainRng)
Set list1Dict = GetDictionary(list1Rng)
ColorMatchingRange2 list1Rng, list1Dict, mainDict
End Sub
Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
Dim unionRng As Range
Dim vals As Variant
Dim i As Long
vals = rng1.Value 'oringinal code transposed with = Application.Transpose(rng1.Value)
Set unionRng = rng1.Offset(rng1.Rows.Count).Resize(1, 1)
For i = LBound(vals) To UBound(vals)
If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
Next i
Set unionRng = Intersect(unionRng, rng1)
If Not unionRng Is Nothing Then
With unionRng.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End If
End Sub
Function GetDictionary(rng As Range) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
Dim vals As Variant
Dim i As Long
vals = rng.Value 'oringinal code transposed with=Application.Transpose(rng.Value)
On Error Resume Next
For i = LBound(vals) To UBound(vals)
dict.Add vals(i), rng(1, i).Address
Next i
On Error GoTo 0
Set GetDictionary = dict
End Function
Function GetRangeRow(ws As Worksheet, rowIndex As String) As Range
With ws '<--| reference passed worksheet
Set GetRangeRow = .Range("A" & rowIndex, .Cells(1, .Columns.Count).End(xlToLeft)) '<--| set its row "rowIndex" range from row 1 right to last non empty column
End With
End Function
More background, the VBA will be in a Control Workbook with the set header list, and the code will run on the ActiveWorkbook which will be the data across many worksheets, but I believe I've got that figured out.
Simpler approach:
Sub HighlightMatchedHeaders()
Dim rngList As Range, c As Range, v
Dim sht As Worksheet, wb As Workbook
Set wb = ActiveWorkbook 'or whatever
'set the lookup list
With wb.Sheets("list")
Set rngList = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For Each sht In wb.Worksheets
'ignore the "list" sheet
If sht.Name <> rngList.Worksheet.Name Then
'checking row 1
For Each c In Application.Intersect(sht.Rows(1), sht.UsedRange).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'has a header: check for match
If Not IsError(Application.Match(v, rngList, 0)) Then
c.Interior.Color = vbRed 'show match
End If
End If
Next c
End If
Next sht
End Sub
I want to get a list of distinct value based on a criteria, example : I have a list of stores, and i want to get only distinct value based on retailer criteria "BOULANGER".
Sub distinctValues()
Dim LastRow As Long
Dim Crit1 As String
LastRow = Sheets("SOURCE").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("SOURCE").Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("TEST").Range("E2"), CopyToRange:=Sheets("TEST").Range("A12"), Unique:=True
End Sub
I suspect your Criteria Range is not properly set up and/or named on your worksheet.
In the .AdvancedFilter, you have:
Range(Crit1)
which, according to your code, will be interpreted as:
Range("BOULANGER")
This presumes you have a Named Range somewhere on your Test Worksheet that is named BOULANGER and refers to two cells in a column, the first of which contains Store and the second contains BOULANGER
If you have that set up properly, then your code works.
Note that in your screen shot showing the criteria, the first cell contains Criteria and not Store. So even if you had the defined range setup to encompass those two cells, it would not work since the first row has to have an identical name to the column being filtered.
This should accomplish what you are trying to do; see comments in the code.
Sub ListUniqueValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'change as needed
ws1.Range("B1", ws1.Cells(Rows.Count, "B").End(xlUp)).Copy ws2.Range("C1") 'copy the full range from sheet1
ws2.Range("C1", ws2.Cells(Rows.Count, "C").End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo 'remove duplicates
Dim lRow As Long
lRow = ws2.Cells(Rows.Count, 3).End(xlUp).Row 'set lastrow variable
For i = lRow To 1 Step -1 'Da Loop, from bottom to top
'change the cell address after "Like" to the cell address where you put your store criteria
'the line will delete any store name that is not like your store criteria
'the (& "*") inserts the wildcard after your store criteria you type in your designated cell, e.g. "BOULANGER*"
If Not ws2.Cells(i, 3).Value Like ws2.Cells(1, 1).Value & "*" Then '
ws2.Cells(i, 3).Delete 'delete the cells that do not match your store criteria
End If
Next i
End Sub
If you are trying to get a unique range that contains a keyword, something like this should work.
Option Explicit
Private Sub OutputUniqueRange(SearchRange As Range, Keyword As String, OutputRange As Range)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In SearchRange
With cell
If InStr(1, .Value2, Keyword, vbTextCompare) > 0 And Not dict.exists(.Value2) Then dict.Add .Value2, .Value2
End With
Next
If dict.Count = 0 Then Exit Sub
OutputRange.Range(OutputRange.Cells(1, 1).Address).Resize(dict.Count, 1) = Application.Transpose(dict.items())
End Sub
Public Sub TestSub()
Dim SearchRange As Range
Dim Keyword As String
Dim OutputRange As Range
Keyword = "Boulanger"
Set SearchRange = ThisWorkbook.Sheets("Sheet1").Range("A2:A34")
Set OutputRange = ThisWorkbook.Sheets("Sheet1").Range("B2")
OutputUniqueRange SearchRange, Keyword, OutputRange
End Sub
I have a spreadsheet that is updated regularly. Therefore the column header positions change regularly. eg. today "Username" is column K, but tomorrow "Username" might be column L. I need to add a new column to the right of "Username" but where it changes I cannot refer to as cell/column reference.
So far I have:
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find("Username")
When I go to add a new column to the right of it, I'm selecting that row but it's going back to cell/column references...
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Range("K1").Select
ActiveCell.FormulaR1C1 = "Role"
How can I perform this step with a macro?
edit: I think need to give that Column a header name and begin populating the row with data - each time I do begins the cell references which I want to avoid wherever possible.
Many thanks in advance.
How about:
Sub qwerty()
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find(what:="Username", After:=Cells(1, 1))
rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
rngUsernameHeader.Offset(0, 1).Value = "role"
End Sub
Sub AddColumn
Dim cl as Range
For each cl in Range("1:1")
If cl = "username" Then
cl.EntireColumn.Insert Shift:= xlToRight
End If
cl.Offset(0, 1) = "role"
Next cl
End Sub
Untested code as not at my desktop
Something like this should work. The idea is that you locate the column and then you insert to the right. That is why you have the +1 in the TestMe. The function l_locate_value_col returns the column, where it has found the value. If you want, you may change the optional parameter l_row, depending on which row do you want to look for.
Option Explicit
Public Sub TestMe()
Dim lngColumn As Long
lngColumn = l_locate_value_col("Username", ActiveSheet)
Cells(1, lngColumn + 1).EntireColumn.Insert
End Sub
Public Function l_locate_value_col(target As String, _
ByRef target_sheet As Worksheet, _
Optional l_row As Long = 1)
Dim cell_to_find As Range
Dim r_local_range As Range
Dim my_cell As Range
Set r_local_range = target_sheet.Range(target_sheet.Cells(l_row, 1), target_sheet.Cells(l_row, Columns.Count))
For Each my_cell In r_local_range
If target = Trim(my_cell) Then
l_locate_value_col = my_cell.Column
Exit Function
End If
Next my_cell
l_locate_value_col = -1
End Function
You could name your range:
Sub Test()
Dim rngUsernameHeader As Range
'UserName is in column F at the moment.
Set rngUsernameHeader = Range("UserName")
Debug.Print rngUsernameHeader.Address 'Returns $F$1
ThisWorkbook.Worksheets("Sheet2").Range("E:E").Insert Shift:=xlToRight
Debug.Print rngUsernameHeader.Address 'Returns $G$1
End Sub
Edit:
Have rewritten so it inserts a column after your named column and returns that reference:
Sub Test()
Dim rngUsernameHeader As Range
Dim rngMyNewColumn As Range
Set rngUsernameHeader = Range("UserName")
rngUsernameHeader.Offset(, 1).Insert Shift:=xlToRight
'You'll need to check the named range doesn't exist first.
ThisWorkbook.Names.Add Name:="MyNewRange", _
RefersTo:="='" & rngUsernameHeader.Parent.Name & "'!" & _
rngUsernameHeader.Offset(, 1).Address
Set rngMyNewColumn = Range("MyNewRange")
MsgBox rngMyNewColumn.Address
End Sub
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps