I have a simple macro that uses a dictionary in order to create a mapping of numbers in a range. I have it map unique values and I can see how it's creating a tally of frequency of occurrence, but I don't know how I'd transfer this working memory onto a sheet? I would just like these unique values printed with maybe the frequency of occurrence next to them.
Sub Frequency()
Dim dict As Object
Dim cl As Range, rng As Range
Set dict = CreateObject("Scripting.Dictionary")
Set rng = Range("A1:D7")
For Each cl In rng.Cells
dict(cl.Value) = dict(cl.Value) + 1
Next
'here is where I'd want it to paste into a new sheet so I can apply conditional formatting
End Sub
You can add the few lines at the bottom here
Sub Frequency()
Dim dict As Object
Dim cl As Range, rng As Range
Set dict = CreateObject("Scripting.Dictionary")
Set rng = Range("A1:D7")
For Each cl In rng.Cells
dict(cl.Value) = dict(cl.Value) + 1
Next
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Range("A1").Resize(dict.Count) = Application.Transpose(dict.keys)
ws.Range("B1").Resize(dict.Count) = Application.Transpose(dict.items)
End Sub
Related
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
I'm creating a dictionary from multiple worksheets and ranges.
My code is working, but is very unpleasant to look at.
There should be something fundamental missing in my knowledge, which is not surprise, as this is my first project in VBA.
How to achieve this in a single loop?
Any help is highly appreciated.
' Get the range of all the adjacent data using CurrentRegion
Dim rg1 As Range, rg2 As Range, rg3 As Range, rg4 As Range, rg5 As Range, rg6 As Range, rg7 As Range
Set rg1 = sheet1.Range("A1").CurrentRegion
Set rg2 = sheet2.Range("A1").CurrentRegion
Set rg3 = sheet3.Range("A1").CurrentRegion
Set rg4 = sheet4.Range("A1").CurrentRegion
Set rg5 = sheet5.Range("A1").CurrentRegion
Set rg6 = sheet6.Range("A1").CurrentRegion
Set rg7 = sheet7.Range("A1").CurrentRegion
Dim oID As clsItem, i As Long, j As Long, Id As Long
'read through the data
For i = 3 To rg1.rows.count
Id = rg1.Cells(i, 1).value
' Create a new clsDetector object
Set oID = New clsItem
' Add the new clsDetector object to the dictionary
dictName.add Id, oID
' Set the values
oID.ItemName = rg1.Cells(i, 70).value
Next i
'
'
'Same loops for rg2, rg3, rg4, rh5, rg6 and rg7
'
'
Since the sheets goes from 1 to 7 you can loop through them like this.
Sub LoadRangesIntoDict()
Dim i As Integer
Dim s As Integer
Dim ws As Worksheet
Dim rng As Range
Dim oID As clsItem, i As Long, j As Long, Id As Long
' Loop through each sheet
For s = 1 To 7
Set ws = Sheets("Sheet" & s)
Set rng = ws.Range("A1").CurrentRegion
'read through the data
For i = 3 To rng.Rows.Count
Id = rng.Cells(i, 1).Value
' Create a new clsDetector object
Set oID = New clsItem
' Add the new clsDetector object to the dictionary
dictName.Add Id, oID
' Set the values
oID.ItemName = rng.Cells(i, 70).Value
Next i
Next s
End Sub
I have a table with 66 columns (representing the Wind turbines) and about 5000 rows of timestamps. I have to check if the value of each cell, in this case velocity, meets a certain criteria, if it does, i extract name of the Wind turbine from the topmost row. Using the name, i need to "lookup" the Wind turbine closest to it from a Matrix in a different sheet and return this.
Option Explicit
Public Sub ErsetzenNachbar()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Arr As Variant
Dim Rng As Range
Dim SheetName As String
Dim i As Long
Dim j As Long
Dim WeaMat As Workbook
Dim Mat As Range
Dim Arr2 As Variant
Dim target As Long
Dim MOfound As String
SheetName = "INPUT_WIND"
'Range in the first Workbook
Set Rng = wb.Worksheets(SheetName).Range("C2:AG5000")
'Open the second Workbook
Set WeaMat = Workbooks.Open("C:\Users\Nikhil.srivatsa\Desktop\WeaMat")
'Set range for second workbook with the Matrix
Set Mat = WeaMat.Worksheets(1).Range("A2:AP68")
'Range into array
Arr = Rng.Value
'loop through array
For i = LBound(Arr, 1) To UBound(Arr, 1)
For j = LBound(Arr, 2) To UBound(Arr, 2)
If Arr(i, j) = 0.047 Then
'wind turbine Name from the topmost row
Arr(LBound(Arr, 1), j) = target
'look for target in the Matrix and fetch the neighboring turbine here is where i need help!
End If
Next j
Next i
End Sub
For example I look for the cells containing 0,047 (may vary) and get "MO30" the turbine name. Now i lookup MO30 in the Matrix of a second workbook and ask it to fetch MO42 from the Matrix since it is the first closest wind turbine.
would using Collections or Dictionary help in this case? or should I create an array out the Matrix? or use the Find function ?
Here is a simple example using two sheets rather than two workbooks, but see if you can adapt it for your set up.
Sub x()
Dim rFind1 As Range, s As String, rFind2 As Range
With Sheet1.Range("A1").CurrentRegion
Set rFind1 = .Find(what:=0.047, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False) 'look for value on sheet1
If Not rFind1 Is Nothing Then
s = .Rows(1).Cells(rFind1.Column) 'if found, find corresponding row 1 value
Set rFind2 = Sheet2.columns(1).Find(what:=s) 'look for this in sheet2
If Not rFind2 Is Nothing Then MsgBox rFind2.Offset(, 1) 'report contents of cell to the right
End If
End With
End Sub
Sheet1
Sheet2
Try this code, please:
Sub findTurb()
Dim sh As Worksheet, sh2 As Worksheet, rng As Range, strTurb As String
Const timeSt As Double = 0.047
Set sh = ActiveSheet 'use here your sheet
Set sh2 = Worksheets("second") 'use here your sheet
Set rng = sh.UsedRange.Find(timeSt)
If Not rng Is Nothing Then
strTurb = sh.Cells(1, rng.Column).value
Set rng = sh2.Range("A1:A" & sh2.Range("A" & Cells.Rows.Count).End(xlUp).Row).Find(strTurb)
If Not rng Is Nothing Then
MsgBox rng.Offset(, 1).value
End If
End If
End Sub
It can be transformed in a function, receiving time stamp as parameter and returning a string...
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
An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub