I have a fairly simple request in Excel using VBA, but I can't think of a way to do it, and I can't find any solutions online.
I have selected multiple columns, and I want to use a macro to expand the selection either side of each selected column.
So for instance I have highlighted columns G, K and Z, and I want to be able to have highlighted F-H, J-L, and Y-AA.
Hope that makes sense, many thanks!
I'm not supposed to answer questions that don't have code examples but this question is impossible to solve without a lot of experience working with ranges.
Outer Loop (Area): Iterate through each Area in Selection.Areas
Inner Loop (Item): Iterate all the Column references
Create a New Range that references the `Area.EntireRow.Columns(Item)
If the Target is Nothing: Set Target = NewRange
Else Set Target = Union(Target, NewRange )
Demo
Sub TestExpandRange()
Application.Goto ExpandRange(Selection, "H", "J:L", "Y:AA")
End Sub
Function ExpandRange(Source As Range, ParamArray ColumnArgs() As Variant) As Range
Dim Target As Range
Dim NewRange As Range
Dim Area As Range
Dim Item As Variant
For Each Area In Source.Areas
For Each Item In ColumnArgs
Set NewRange = Area.EntireRow.Columns(Item)
If Target Is Nothing Then
Set Target = NewRange
Else
Set Target = Union(Target, NewRange)
End If
Next
Next
Set ExpandRange = Target
End Function
Edit 1
This will add the extra columns to the Selection
Function ExpandRange2(Source As Range, ParamArray ColumnArgs() As Variant) As Range
Dim Target As Range
Dim NewRange As Range
Dim Area As Range
Dim Item As Variant
Set Target = Source
For Each Area In Source.Areas
For Each Item In ColumnArgs
Set NewRange = Area.EntireRow.Columns(Item)
Set Target = Union(Target, NewRange)
Next
Next
Set ExpandRange2 = Target
End Function
Edit 2
Sub SelectAdjacentColumns()
Dim Target As Range
Dim NewRange As Range
Dim Area As Range
For Each Area In Selection.Areas
If Area.Column = 1 Then
Set NewRange = Area.Resize(, 2).EntireColumn
ElseIf Area.Column = Columns.Count Then
Set NewRange = Area.Offset(, -1).Resize(, 2).EntireColumn
Else
Set NewRange = Area.Offset(, -1).Resize(, 3).EntireColumn
End If
If Target Is Nothing Then
Set Target = NewRange
Else
Set Target = Union(Target, NewRange)
End If
Next
Target.Select
End Sub
Related
I have been working on automating different parts of the process of formatting a very large data set. I am stuck on trying to automate the "remove duplicates" command across all blocks of my data:
I have blocks of data (9 columns wide, x rows long) as on the image attached. In the column called "#Point ID" are values 0-n. Some values appear once, some values appear more than once. Different blocks have different "#Point ID" columns
I would like to delete all rows in the block where the value in the "#Point ID" column has already occurred (starting from the top, moving down the rows). I would like the deleted rows removed from the blocks, so only the rows (which are blue on the image) with unique values in "#Point ID" column (green on the image) remain.
I have found VBA modules that work on a single block, but I don't know how to make it function across all my blocks. Delete rows in Excel based on duplicates in Column
I have also tried combinations of functions (inc. UNIQUE and SORTBY) without any success.
What's a function or a VBA module that works?
Use this
Public Sub cleanBlock(rng As Range)
Dim vals As Object
Set vals = CreateObject("Scripting.Dictionary")
Dim R As Range
Dim adds As Range
For Each R In rng.Rows
If (vals.exists(R.Cells(1, 2).Value)) Then
If adds Is Nothing Then
Set adds = R
Else
Set adds = Union(adds, R)
End If
Else
vals(R.Cells(1, 2).Value) = True
End If
Next R
Debug.Print (adds.Address)
If Not adds Is Nothing Then adds.Delete shift:=xlUp
Set vals = Nothing
End Sub
Public Sub test()
cleanBlock Range("b3:j20")
cleanBlock Range("l3:t20")
cleanBlock Range("y3:ad20")
End Sub
Remove Duplicates in Areas of a Range
Sub RemoveDupesByAreas()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
Dim aCount As Long: aCount = rg.Areas.Count
Dim arg As Range, a As Long
For a = aCount To 1 Step -1
Set arg = rg.Areas(a)
Debug.Print a, arg.Address(0, 0)
' Before running the code with the next line, in the Immediate
' window ('Ctrl+G'), carefully check if the range addresses
' match the areas of your data. If they match, uncomment
' the following line to apply remove duplicates.
'arg.RemoveDuplicates 2, xlYes
Next a
MsgBox "Duplicates removed.", vbInformation
End Sub
Find and FindNext feat. CurrentRegion
Sub RemoveDupesByFind()
Const SEARCH_STRING As String = "Source.Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange
Dim fCell As Range: Set fCell = rg.Find( _
SEARCH_STRING, , xlFormulas, xlWhole, xlByRows, xlPrevious)
If fCell Is Nothing Then
MsgBox """" & SEARCH_STRING & """ not found.", vbCritical
Exit Sub
End If
Dim FirstAddress As String: FirstAddress = fCell.Address
Do
fCell.CurrentRegion.RemoveDuplicates 2, xlYes
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
MsgBox "Duplicates removed.", vbInformation
End Sub
Another way, maybe something like this :
Sub test()
Dim rgData As Range
Dim rg As Range: Dim cell As Range
Dim rgR As Range: Dim rgDel As Range
Set rgData = Sheets("Sheet1").UsedRange 'change as needed
Set rgData = rgData.Resize(rgData.Rows.Count - 1, rgData.Columns.Count).Offset(1, 0)
For Each rg In rgData.SpecialCells(xlConstants).Areas
For Each cell In rg.Columns(2).Cells
Set rgR = cell.Offset(0, -1).Resize(1, rg.Columns.Count)
If cell.Value = 0 And cell.Offset(1, 0).Value <> 0 And cell.Offset(0, 1).Value = 0 And cell.Address = rg.Columns(2).Cells(1, 1).Address Then
Else
If Application.CountIf(rg.Columns(2), cell.Value) > 1 And cell.Offset(0, 1).Value = 0 Then
If rgDel Is Nothing Then Set rgDel = rgR Else Set rgDel = Union(rgDel, rgR)
End If
End If
Next cell
Next rg
rgDel.Delete Shift:=xlUp
End Sub
The code assumed that there'll be no blank cell within each block and there will be full blank column (no value at all) between each block. So it sets the usedrange as rgData variable, and loop to each area/block in rgData as rg variable.
Within rg, it loop to each cell in rg column 2, and check if the count of the looped cell value is > 1 and the value of the looped cell.offset(0,1) is zero, then it collect the range as rgDel variable.
Then finally it delete the rgDel.
If you want to step run the code, try to add something like this rg.select ... rgR.select .... after the variable is set. For example, add rgDel.select right before next area, so you can see what's going on.
The code assume that :
the first value right under "#Point" in each block will be always zero. It will
never happen that the value is other than zero.
the next value (after that zero value) is maybe zero again or maybe one.
if there are duplicates (two same value) in column #Point then in column X, it's not fix that the first one will always have value and the second one will always zero value.
If the data is always fix that the first one will always have value and the second one will always zero value (if there are duplicate), I suggest you to use Mr. VBasic2008 or Mr. wrbp answer. Thank you.
I have A1 =1 which is the number of tables. If the value in the cell changes - a new table is added. I have a macro that searches it (code below). How can I make it search the range if I know that:
distances between each table are constant (5 empty cells)
table currently has fixed value (but will change in future)
i know number of tables
I am looking for a way that, for each next table (A1), the range of searching it, will change to this added one.
I would especially ask for help with setting up .Range.
The mentioned code:
Sub pulling_row_number_if_it_finds_the_code_in_the_table()
Dim my_cell As Object
Dim nr_row_code_found As Integer
Dim my_Range As Range
With Worksheets("Sheet1")
Set my_Range = Range("A5:A50")
For Each my_cell In my_Range
If my_cell.Value = .Range("B1").Value Then
nr_row_code_found = my_cell.Row
.Range("F1") = nr_ row_code_found
End If
Next my_cell
End With
End Sub
If the tables are all the same size:
Sub pulling_row_number_if_it_finds_the_code_in_the_table()
Dim my_Range As Range, m, tblNum As Long
Dim rngT1 As Range
With Worksheets("Sheet1")
Set rngT1 = .Range("A5:A50") 'first table
tblNum = .Range("A1").Value
Set my_Range = rngT1.Offset((tblNum - 1) * (rngT1.Rows.Count + 5))
m = Application.Match(.Range("B1").Value, my_Range, 0)
If Not IsError(m) Then 'if got a match
.Range("F1") = my_Range.Cells(m).Row
Else
.Range("F1") = "no match"
End If
End With
End Sub
I'm currently working on the statement that implies, that if any of the cell value in the range of "G3:ED3" in the worksheet named "Matrix", matches the cell value in the range of "H3:H204" in the worksheet named "Staff" and any cell value in the range "G5:ED57" in the "Matrix" worksheet is numeric, then the value of the cell in a column B, that intersects the numeric value, is retrieving to the required cell address in the target template.
Here's what I have tried so far:
Dim rng1 As Range
Set rng1 = Worksheets("Matrix").Range("G3:ED3")
Dim rng2 As Range
Set rng2 = Worksheets("Staff").Range("H3:H204")
Dim rng3 As Range
Set rng3 = Worksheets("Matrix").Range("G5:ED57")
For Each cell In Range(rng1, rng2, rng3)
While IsNumeric(rng3) And rng1.Value = rng2.Value
Worksheets("Matrix").Columns("B").Find(0).Row =
Worksheets("TEMPLATE_TARGET").Value(12, 4)
Wend
I'm unsure how to define the statement, so the code would automatically retrieve the value of the cell in a column B, that intersects any cell that contains numeric value in the rng3. Any recommendations would be highly appreciated.
it's probably best you take a proper look into documentation / whatever learning resource you are using as you seem to have missunderstood how While works (alongside few other things)
While is a loop within itself, it does not act as an Exit Condition for the For loop.
With all that said, it's also unclear from your question what you're trying to achieve.
My presumption is, that you want to check for all the conditions and
then if they do match, you're looking to paste the result into the
"TEMPLATE" sheet
First we create a function th ceck for values in the two data ranges:
Private Function IsInColumn(ByVal value As Variant, ByVal inSheet As String) As Boolean
Dim searchrange As Range
On Error Resume Next ' disables error checking (Subscript out of range if sheet not found)
' the range we search in
If Trim(LCase(inSheet)) = "matrix" Then
Set searchrange = Sheets("Matrix").Range("G5:ED7")
ElseIf Trim(LCase(inSheet)) = "staff" Then
Set searchrange = Sheets("Staff").Range("H3:H204")
Else
MsgBox ("Sheet: " & inSheet & " was not found")
Exit Function
End If
On Error GoTo 0 ' re-enable error checking
Dim result As Range
Set result = searchrange.Find(What:=value, LookIn:=xlValues, LookAt:=xlWhole)
' Find returns the find to a Range called result
If result Is Nothing Then
IsInColumn = False ' if not found is search range, return false
Else
If IsNumeric(result) Then ' check for number
IsInColumn = True ' ding ding ding, match was found
Else
IsInColumn = False ' if it's not a number
End If
End If
End Function
And then we run the procedure for our search.
Private Sub check_in_column()
Dim looprange As Range: Set looprange = Sheets("Matrix").Range("G3:ED3")
Dim last_row As Long
For Each cell In looprange ' loops through all the cells in looprange
'utlizes our created IsInColumn function
If IsInColumn(cell.Value2, "Matrix") = True And _
IsInColumn(cell.Value2, "Staff") = True Then
' finds last actively used row in TEMPLATE_TARGET
last_row = Sheets("TEMPLATE_TARGET").Cells(Rows.Count, "A").End(xlUp).Row
' pastes the found value
Sheets("TEMPLATE_TARGET").Cells(last_row, "A") = cell.Value2
End If
' otherwise go to next cell
Next cell
End Sub
I redefined your ranges a little in my example for utility reasons but it works as expected
In my Matrix sheet: (staff sheet only contains copy of this table)
In my TEMPLATE_TARGET sheet after running the procedure.
Result as expected
If I understand well, I would have done something like this:
Option Explicit
Public Sub Main()
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G3:ED3")
Dim cell As Range
Dim cellStaff As Range
Dim cellMatrix As Range
For Each cell In rgMatrix
If CheckRangeStaff(cell.Range) And CheckRangeMatrix() Then
'Process in a column B? Which sheet? Which cell? Which Process?
End If
Next cell
Debug.Print ("End program.")
End Sub
Public Function CheckRangeStaff(ByVal value As String) As Boolean
Dim wsStaff As Worksheet: Set wsStaff = ThisWorkbook.Worksheets("Staff")
Dim rgStaff As Range: Set rgStaff = wsStaff.Range("H3:H204")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgStaff
If cell.value = value Then
res = True
Exit For
End If
Next cell
CheckRangeStaff = res
End Function
Public Function CheckRangeMatrix() As Boolean
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G5:ED57")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgMatrix
If IsNumeric(cell.value) Then
res = True
Exit For
End If
Next cell
CheckRangeMatrix = res
End Function
Private Sub ComboBox8_Change()
Dim vRow As Double
Dim rPICRange As Range
Dim rComRange As Range
Set rComRange = dbComWB.Worksheets("CustomerList").Range("B2")
Set rComRange = Range(rComRange, rComRange.End(xlDown))
vRow = Application.WorksheetFunction.Match(Me.ComboBox8.value, rComRange, 0)
Set rPICRange = dbComWB.Worksheets("CustomerList").Range(Cells(vRow + 1, 14).Address)
Set rPICRange = Range(rPICRange, rPICRange.End(xlToRIght))
Me.ComboBox9.RowSource = rPICRange.Address(external:=True)
End Sub
Above are my code that want to fill a combobox but the "rPICRange" set to Rowsource as a single range instead of a list.
I do tried printout individual value of "rPICRange" & "rPICRange.end(xlToRight)" before assign to RowSource, it is correct value i want.
I also debug by changing .End(xlToRight) to other direction. Seen to me .End(xlUp) & .End(xlDown) work fine but Right & left is mess up.
Edit:
Is that because of ComboBox.RowSource only accept range in row (xlIp/xlDown), but not range in column (xlToRight/xlToLeft). If yes, how can i "Transpose" the range?
Set rPICRange = Application.WorksheetFunction.Transpose(Range(Cells(vRow + 1, 14).Address, rPICRange.End(xlToRight)))
Code above not working for me.
You cannot use Range without a parent worksheet reference even if you are defining it with range objects that have parent worksheet objects in a private sub or any sub in a worksheet code page. See Is the . in .Range necessary when defined by .Cells? for an extended discussion on this.
Option Explicit
Private Sub ComboBox8_Change()
Dim vRow As Double
Dim rPICRange As Range
Dim rComRange As Range
With dbComWB.Worksheets("CustomerList")
Set rComRange = .Range("B2")
Set rComRange = .Range(rComRange, rComRange.End(xlDown))
End With
vRow = Application.WorksheetFunction.Match(Me.ComboBox8.Value, rComRange, 0)
With dbComWB.Worksheets("CustomerList")
Set rPICRange = .Cells(vRow + 1, 14)
Set rPICRange = .Range(rPICRange, rPICRange.End(xlToRight))
End With
Me.ComboBox9.RowSource = rPICRange.Address(external:=True)
End Sub
I'm not entirely sure what you were trying to accomplish with the Range.Address property but I believe I've rectified it.
Private Sub ComboBox8_Change()
Dim vRow As Double
Dim Rng As Range
Dim rPICRange As Range
Dim rComRange As Range
Set rComRange = dbComWB.Worksheets("CustomerList").Range("B2")
Set rComRange = Range(rComRange, rComRange.End(xlDown))
Me.ComboBox9.Clear
vRow = Application.WorksheetFunction.Match(Me.ComboBox8.value, rComRange, 0)
Set rPICRange = dbComWB.Worksheets("CustomerList").Range(Cells(vRow + 1, 14).Address)
Set rPICRange = Range(rPICRange, rPICRange.End(xlToRight))
'code below add each range value into the list
For Each Rng In rPICRange
Me.ComboBox9.AddItem Rng.value
Next Rng
End Sub
Thank to YowE3K. I finally manage to get it working.
Lesson Learned:
RowSource indeed for Row range only, when input Column range will only get the first data.
I have built a few templates of differing rows (same columns) that I want to be pulled in and inserted based on changing a cell value.
So if you change A1 to value of temp1 it will insert rows/values of the "temp1" template array (100 rows) from another sheet, and if you change A101 to value of temp2 it will insert rows/values of the "temp2" template array (25 rows) from another sheet.
You asked to insert rows, not to clean up the sheet and then paste the rows.
The attached Worksheet_Change even code is an example of how to accomplish what you are specifying ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim srcSht As Worksheet
Dim lstRow As Long, lstCol As Long
Dim srcRng As Range
Dim tarRng As Range
If Target.Address = "$A$1" Then
Set tarRng = ActiveSheet.Range("A2")
If Target.Value = "temp1" Then Set srcSht = Worksheets("Shtemp1")
If Target.Value = "temp2" Then Set srcSht = Worksheets("Shtemp2")
If srcSht Is Nothing Then Exit Sub
lstRow = srcSht.Range("A" & srcSht.Rows.Count).End(xlUp).Row
Set srcRng = srcSht.Range(srcSht.Cells(1, 1), srcSht.Cells(lstRow, 1))
srcRng.EntireRow.Copy
tarRng.EntireRow.Insert shift:=xlDown
End If
Set tarRng = Nothing
Set srcRng = Nothing
Set srcSht = Nothing
End Sub
Below is a screen cap of Shtemp1 ...
... and a screen cap of Shtemp2 ...
When "temp1" is typed into Cell A1 of the worksheet with the code attached, you get this ...
... changing Cell A1 to "temp2", you get this ...