Search column headers and insert new column using Excel VBA - excel

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

Related

how to get last row that has velue Excel VBA within a range

I am new to VBA Macro. i just want to know how to get the last row that has value within a range
Set MyRange = Worksheets(strSheet).Range(strColumn & "1")
GetLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
this code could find the last row for the whole sheet.. i just want it to find the last non null value cells
(
like in this case in the picture.. for the ("A8") range, the last row result should be ("A9:B9")
"A9:B9" cannot be last row... It is a range.
If you need such a range, but based on the last empty row, starting from a specific cell, you can use the next approach:
Sub testLastRowRange()
Dim sh As Worksheet, myRange As Range, lastRow As Long, strColumn As String
Dim lastCol As Long, endingRowRng As Range, strSheet As String
strSheet = ActiveSheet.Name 'please, use here your real sheet name
Set sh = Worksheets(strSheet)
strColumn = "A"
Set myRange = sh.Range(strColumn & 8)
lastRow = myRange.End(xlDown).row
lastCol = myRange.End(xlToRight).Column
Set endingRowRng = sh.Range(sh.Cells(lastRow, myRange.Column), sh.Cells(lastRow, lastCol))
Debug.Print endingRowRng.address
End Sub
For your specific example you could use CurrentRegion property.
This is based on the ActiveCell which is not generally advisable.
Sub x()
Dim r As Range
Set r = ActiveCell.CurrentRegion
MsgBox r.Address
End Sub

Find string in one worksheet and select it in another

I've got Workbook where I got names and hours worked of employees. I'm looking for comparing rows in one worksheet (Range B6:CC6) and find it in another with selection on cell with employee name (Range A1:A5000) when I change sheets from 1 to 2.
Tried some Range.Find and others, no idea how to do it
Public Sub FindPosition()
Dim Actcol As Integer, Pos As Range, Name As Range
Actcol = ActiveCell.Column
MsgBox "ActiveCell is" & Actcol
Set Pos = Cells(6, Actcol)
MsgBox Pos
Pos.Select
If Worksheets("Sheet2").Activate Then
Worksheets("Sheet2").Range("A1:AA5100").Select
Set Name = Selection.Find(Pos, LookIn:=xlValues)
End If
End Sub
First, if you want to trigger some macro by activation of Sheet2, you need to handle Activate event of Sheet2. This can be done by declaring subroutine in Sheet module like this.
Private Sub Worksheet_Activate()
'Codes you want to be run when Sheet2 is activated.
End Sub
Second, a simple way to find a cell with specific value is to use WorksheetFunction.Match. For example,
Dim SearchInRange As Range
Set SearchInRange = Range("A1:A5000")
Dim EmployeeName As Variant
EmployeeName = ... 'Actual employee name you want to search
On Error GoTo NotFound
Dim Index As Variant
Index = WorksheetFunction.Match(EmployeeName, SearchInRange, 0)
On Error GoTo 0
SearchInRange.Cells(Index).Select
GoTo Finally
NotFound:
' Handle error
Finally:
Range.Find may also work, but remember it has the side effect of changing the state of "Find and Replace" dialog box.
This may helps you
Option Explicit
Sub test()
Dim i As Long, LastRowA As Long, LastRowB As Long
Dim rngSearchValues As Range, rngSearchArea As Range
Dim ws1 As Worksheet, ws2 As Worksheet
'Set you worksheets
With ThisWorkbook
'Let say in this worksheet you have the names & hours
Set ws1 = .Worksheets("Sheet1")
'Let say in this worksheet you have the list of names
Set ws2 = .Worksheets("Sheet2")
End With
'Find the last row of the column B with the names from the sheet with names & hours
LastRowB = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
'Find the last row of the column A with the names from the sheet with list of names
LastRowA = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
'Set the range where you want to check if the name appears in
Set rngSearchArea = ws2.Range("A1:A" & LastRowA)
'Loop the all the names from the sheet with names and hours
For i = 6 To LastRowB
If ws1.Range("B" & i).Value <> "" Then
If Application.WorksheetFunction.CountIf(rngSearchArea, "=" & ws1.Range("B" & i).Value) > 0 Then
MsgBox "Value appears"
Exit For
End If
End If
Next i
End Sub
Oh right, I found solution. Thanks everyone for help.
Public Sub Position()
Dim Accol As Integer
Dim Pos As Range
Dim name As Range
ActiveSheet.name = "Sheet1"
Accol = ActiveCell.Column
Set Pos = Cells(6, Accol)
Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("a1:a5000").Select
Set name = Selection.Find(What:=Pos, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
name.Select
End Sub
Last thing I would like to do which I cannot solve is where do I write automatically script running when I choose Sheet2?

VBA extract unique values based on criteria

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

Move down one row all cells from one column (offset)

I would like to move down one row all the cells from a column (in my case column C). It means if I have “X” written in cell C1, it should move down to Cell C2, if I have “Y” written in cell C1000,it should move down to Cell C1001…
I have the following error message:
Run time error 1004, application defined or object defined error
Sub movedownrowcolumnC()
Range("C:C").Offset(1).Select
End Sub
try below macro.
Sub MoveDowncolumn()
Dim lastRow As Integer
With Worksheets("Sheet1")
lstrow = .Cells(Rows.Count, "C").End(xlUp).Row
For i = lstrow To 1 Step -1
.Cells(i + 1, "C").Value = .Cells(i, "C").Value
Next i
End With
End Sub
use:
Cells(Rows.Count, "C").End(xlUp).Offset(1).Select
although you most probably don't need to Select anything and just go with the Range variable:
Sub movedownrowcolumnC()
Dim myRange As Range
Set myRange = Cells(Rows.Count, "C").End(xlUp).Offset(1)
myRange.Value = "myValue"
End Sub
While much more than just "good coding practice" is to always explicitly qualify a Range object up to its Worksheet reference:
Sub movedownrowcolumnC()
Dim myRange As Range
With Worksheets("mySheetName") ' reference wanted worksheet (change "mySheetName" to your actual relevantsheet name)
Set myRange = .Cells(.Rows.Count, "C").End(xlUp).Offset(1) ' ser referenced worksheet column C cells right below last not empty one
End With
myRange.Value = "myValue"
End Sub
Did you ask for this?
Range("C1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
You can you:
Option Explicit
Sub Test()
With ThisWorkbook.Worksheets("Sheet1")
If .Range("C1").Value = "Test" Then
.Rows(.Range("C1").Row + 1).Select
End If
End With
End Sub

Excel VBA Compact method to insert text in offset column based on FIND result

I am writing a small timesaver tool that inserts various text values in a column based on a cell offset of the location of a list-based text search in column C.
Dim C1 As Range
Set C1 = Range("B:B").Find("Value to search")
If C1 Is Nothing Then
Else
C1.Offset(0, -1).Value = "Text value to insert"
End If
I am certain there is a better way to write this relatively simple proc in a more scalable way rather than hard code each value to search in the code, but am not sure how this could be simplified further. I've been looking at the first two lines, and I may be wrong, but I believe a cell range needs to be defined as written in the first two lines in order for the Offset to know the cell location to offset from.
Depends on how you are planning on running this. You could have it as a sub that prompts a user to enter the search value and the text to input at offset. I show that below. It is easy enough instead to adapt to a loop if you have the search and offset strings in the sheet. I use only the populated area of column B for the search. The search values and insert/offset values are held in variables.
Option Explicit
Public Sub AddText()
Dim searchValue As String, insertValue As String, C1 As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
searchValue = Application.InputBox("Please supply search value", Type:=2)
insertValue = Application.InputBox("Please supply insert value", Type:=2)
If searchValue = vbNullString Or insertValue = vbNullString Then Exit Sub 'or loop prompting for entry
With ws
Set C1 = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Find(searchValue)
End With
If Not C1 Is Nothing Then C1.Offset(0, -1).Value = insertValue
End Sub
Edit:
From your comment you are actually just doing a VLOOKUP.
In sheet 2 A1 put the following and autofill down for as many rows as are filled in column B.
=IFERROR(VLOOKUP(B1,Sheet1!A:B,2,FALSE),"")
Same thing using arrays and a dictionary
Option Explicit
Public Sub AddText()
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim lookupArray(), updateArray(), lookupDict As Object, i As Long
Set lookupDict = CreateObject("Scripting.Dictionary")
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsSearch = ThisWorkbook.Worksheets("Sheet2")
With wsSource
lookupArray = .Range("A1:B" & GetLastRow(wsSource, 1)).Value
End With
For i = LBound(lookupArray, 1) To UBound(lookupArray, 1)
lookupDict(lookupArray(i, 1)) = lookupArray(i, 2)
Next
With wsSearch
updateArray = .Range("A1:B" & GetLastRow(wsSearch, 2)).Value
For i = LBound(updateArray, 1) To UBound(updateArray, 1)
If lookupDict.Exists(updateArray(i, 2)) Then
updateArray(i, 1) = lookupDict(updateArray(i, 2))
End If
Next
.Cells(1, 1).Resize(UBound(updateArray, 1), UBound(updateArray, 2)) = updateArray
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function

Resources