I have a formula looking for the column "NAME", adding a blank column after it and naming this new column "word count". Now I need to apply following formula in the new column:
=TRIM(LEN(E2)-LEN(SUBSTITUTE(E2," ","")))+1
Column E is the "NAME" column; however, the location of this column might change from file to file.
Please, try the next code. It searches for the column header "NAME". in the first row of the active sheet and place the formula referencing the found column, in the second column after the found one:
Sub ApplyFormula()
Dim strColName As String, colRng As Range, lastR As Long, colLetter As String
strColName = "NAME" 'the header to search for
'Supposing that the columns headers are in the first row:
Set colRng = ActiveSheet.rows(1).Find(what:=strColName, LookIn:=xlValues, Lookat:=xlWhole)
If Not colRng Is Nothing Then
colLetter = Split(colRng.Address, "$")(1)
lastR = cells(rows.count, colRng.Column).End(xlUp).row
Range(colRng.Offset(1, 2), cells(lastR, colRng.Column + 2)).Formula = _
"=TRIM(LEN(" & colLetter & "2)-LEN(SUBSTITUTE(" & colLetter & lastR & ","" "","""")))+1"
Else
MsgBox "No """ & strColName & """ in the first row..." & vbCrLf & _
"Please, change the row (in the code) or search an existing header.", vbInformation, _
"No such column header..."
End If
End Sub
Related
I need your help with VBA!
I want to write a code that will sum the "sales" column in different 7 sheets. The problem is that the column has a different location in each sheet and a dinamic rows' count. The sum should be in the last row + 1.
I am not very good at macros, but I guess I should start with checking i to 7 sheets. Then I should sum a range based on the header ("Sales"). I am lost about how to write all of this..
Try the next code, please:
Sub SumSales()
Dim sh As Worksheet, rngS As Range, lastRow As Long
For Each sh In ActiveWorkbook.Sheets 'iterate through all sheets
'find the cell having "Sales" text/value
Set rngS = sh.Range(sh.Cells(1, 1), sh.Cells(1, _
sh.Cells(1, Columns.count).End(xlToLeft).Column)).Find("Sales")
'if the cell has been found (the cell range is NOT Nothing...)
If Not rngS Is Nothing Then
'Determine the last row of the found cell column:
lastRow = sh.Cells(Rows.count, rngS.Column).End(xlUp).row
'Write the Sum formula in the last empty cell:
rngS.Offset(lastRow).formula = "=Sum(" & rngS.Offset(1).address & _
":" & sh.Cells(lastRow, rngS.Column).address & ")"
sh.Range("A" & lastRow + 1).Value = "Sum of sales is:"
Else
'if any cell has been found, it returns in Immediate Window (Being in VBE, Ctrl + G) the sheet names not having "Sales" header:
Debug.Print "No ""Sales"" column in sheet """ & sh.name & """."
End If
Next
End Sub
Excel VBA is finding every other cell using a method to check for Empty Cells. On the next time running the same macro, it then finds the cell that it skipped over on the last run while again skipping the next instance of an empty cell. If I cycle through the macro a few times, eventually every row without data is getting deleted, as per the purpose of the macro. The rows do shift upward upon deletion of the row one at a time, I will try a Union and delete the Range as stated by #BigBen
When a cell that is empty is found, it checks columns A, B, and D to see if formula is applied, and if a formula exists in that row, the entire row gets deleted.
Dim cel, dataCells As Range
Dim rngBlank, dc As Range
Dim lastRow, cForm, c, blnkRange As String
Dim cycleTimes As Integer
On Error Resume Next
Set dataCells = Range("F2:W2").Cells 'This is header of the table of data
cycleTimes = dataCells.Count 'Number of times to cycle through macro
For Count = 1 To cycleTimes 'I don't want to cycle through macro
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find end of column
For Each dc In dataCells
c = Split(Cells(1, dc.Column).Address, "$")(1) 'Column Letter
blnkRange = c & "3:" & c & lastRow 'Range to look over for empty cells
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).Cells
For Each cel In rngBlank '**Skipping Every other Row**
If Not TypeName(cel) = "Empty" Then
cForm = "A" & cel.Row & ",B" & cel.Row & ",D" & cel.Row 'Formula check
If Range(cForm).HasFormula Then
cel.EntireRow.Delete
End If
End If
Next
Next
Next
I was able to use Intersect to find the rows that matched the criteria I was searching for and delete the EntireRow even though the Selection was in separate Rows.
Set dataCells = Range("F2:W2").Cells
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find last row to generate range to look through
For Each dc In dataCells 'Have to perform delete row for every column
c = Split(Cells(1, dc.Column).Address, "$")(1)
blnkRange = c & "3:" & c & lastRow
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).EntireRow
strFormula = "A2:A" & lastRow & ",B2:B" & lastRow & ",C2:C" & lastRow
Set rngFormula = Range(strFormula).SpecialCells(xlCellTypeFormulas)
Intersect(rngFormula, rngBlank).EntireRow.Delete (xlShiftUp) '**THIS helped in deleting Rows**
Next
I'm totally new to the vba. I have two excel sheets, and I'm trying to compare and match the cells in one of the columns in two sheets. If matched cells are found, information of the adjacent cells will be copied and paste to another sheet(sheet1).
I have a code that works just fine but incomplete. Because there are repetitive cells in a column, the code once finds a match and copy-paste the info, it skips to the next non-repeated cells. Thus resulting in a lot of blank, missing cell. Any idea to make it fill in the blank?
Image:
Sheet2:
Sub Button2_Click()
Dim lastRw1, lastRw2, nxtRw, m
lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lastRw2 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
'Loop
For nxtRw = 2 To lastRw2
'Search
With Sheets(1).Range("A2:A" & lastRw1)
Set m = .Find(Sheets(2).Range("B" & nxtRw), LookIn:=xlValues, lookat:=xlWhole)
'Copy
If Not m Is Nothing Then
Sheets(2).Range("C" & nxtRw & ":D" & nxtRw).Copy _
Destination:=Sheets(1).Range("J" & m.Row)
End If
End With
Next
End Sub
Updated:
I took a small sample of your Sheet2 data set:
I also updated your code as follows (main change - I replaced Find with Match in order to find the matching row number):
Dim lastRw1 As Long, lastRw2 As Long, nxtRw As Long, m As Long
lastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lastRw2 = Sheets(2).Range("B" & Rows.Count).End(xlUp).Row
'Loop
For nxtRw = 2 To lastRw1
'Search
With Sheets(1)
m = Application.Match(.Range("A" & nxtRw).Value, _
Sheets(2).Range("B1:B" & lastRw2), 0)
'Copy
If m Then
Sheets(2).Range("C" & m & ":D" & m).Copy _
Destination:=.Range("J" & nxtRw)
End If
End With
Next
Final result:
I have this code and it only works if the header I'm looking for is in column B or "higher".
Lets say I have this table and need to find what column "Name" and "score" is in.
Name score
John 1
Joe 5
If "Name" is in B1 and "score" is in C1 the following code will work:
NameColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
ScoreColumn = Split(Cells(1, Cells(1, 1).EntireRow.Find(What:="score", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, searchdirection:=xlNext, MatchCase:=True).Column).Address(True, False), "$")(0)
^^ <- search value
The above code would in the case return
NameColumn = "B"
ScoreColumn = "C"
But suppose the columns are A & B then it will not find "Name" because it starts searching after cell 1,1 (A1) which is where the header is.
What can I change to make this work, or what alternatives are there to returning "A" and "B" in the example above?
Here is a quick UDF function that i have used in the past.
This may not be the best way to do it, but this is one I have used for many years.
Function ColumnHeaderLocation(entry As String, Optional ColumnNumber As Boolean)
Dim x, y As Long
y = ActiveSheet.Columns.Count
x = 1
Do Until x > y
If ActiveSheet.Cells(1, x).Value = entry Then
ColumnHeaderLocation = Split(ActiveSheet.Cells(1, x).Address(True, False), "$")(0)
If ColumnNumber = True Then ColumnHeaderLocation = x
Exit Function
Else
x = x + 1
End If
Loop
End Function
Simply use the name of the column header (see example)...
NameColumn = ColumnHeaderLocation("Name") ' returns Column Location as a letter
Or
NameColumn = ColumnHeaderLocation("Name", True) ' Returns column Location as a Number
Header Column Letter Calculation
You will have to add the After argument to the Find method pointing to the last cell .Cells(.Cells.Count) to start the search from the first cell .Cells(1). But as chris neilsen in the comments pointed out, this is not the reason your code would fail, because it would find Name at the end of the search.
Since you haven't defined what 'not working' actually means, and it is highly unlikely that you have misspelled Name in A1, I would assume that NameColumn returns an undesired result (<>A) meaning that you have used Name somewhere else in the first row and you really need to start the search from the first cell .Cells(1).
Short Version
Sub FindAfterShort()
Dim NameColumn As String ' Name Column Letter
Dim ScoreColumn As String ' Score Column Letter
With Rows(1)
NameColumn = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
ScoreColumn = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & NameColumn & "' and '" & ScoreColumn & "'."
End Sub
Preferable Version
Sub FindAfterPref()
Const cSheet As String = "Sheet1" ' Worksheet Name
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
With ThisWorkbook.Worksheets(cSheet).Rows(1)
strName = Split(.Find("Name", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
strScore = Split(.Find("Score", .Cells(.Cells.Count), xlValues, _
xlWhole).Address, "$")(1)
End With
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
End Sub
A Small Study
Sub FindAfter()
Const cSheet As String = "Sheet1" ' Worksheet Name
Const cFR As Long = 2 ' First Row
' The column where the Last Row Number will be calculated.
Const cLRColumn As Variant = "A" ' Last-Row Column Letter/Number
Dim rngName As Range ' Name Column Range, Name Range
Dim rngScore As Range ' Score Column Range, Score Range
Dim lngName As Long ' Name Column Number
Dim lngScore As Long ' Score Column Number
Dim strName As String ' Name Column Letter
Dim strScore As String ' Score Column Letter
Dim lngLR As Long ' Last Row Number (Calculated in Last-Row Column)
With ThisWorkbook.Worksheets(cSheet).Rows(1)
' Find Method Arguments
' 2. After: If you want to start the search from the first cell, you
' have to set the After parameter to the last cell. If you
' have the matching data in the first cell and you set the
' parameter to the first cell (default), it will still be
' found, but a little later (not mili, but micro seconds
' later) so it could be omitted.
' 5. SearchOrder: Whenever a range is a one-row or a one-column range,
' this argument can be omitted. Since you're searching
' in a one-row range, "xlByRows" would have been the
' more 'correct' way in this case.
' 6. SearchDirection: This argument's parameter is by default "xlNext"
' and can therefore be omitted
' 7. MatchCase: This argument's parameter is by default "False". Since
' I don't see the reason why you would have headers with
' the same name, especially the ones you don't need
' before the ones you need, it is omitted. If you really
' need it, use "... xlWhole, , , True".
Set rngName = .Find("Name", .Cells(.Cells.Count), xlValues, xlWhole)
Set rngScore = .Find("Score", .Cells(.Cells.Count), xlValues, xlWhole)
' Address Arguments
' If the Address arguments are omitted, Range.Address returns the
' address as an absolute reference e.g. $A$1. When you split
' $A$1 you will get the following
' INDEX STRING
' 0 - Empty string ("").
' 1 A - Use this i.e. index 1 for the split array index.
' 2 1
If Not rngName Is Nothing Then ' When "Name" was found.
' Calculate Name Column Number.
lngName = rngName.Column
' Calculate Name Column Letter.
strName = Split(rngName.Address, "$")(1)
End If
If Not rngScore Is Nothing Then ' When "Score" was found.
' Calculate Score Column Number.
lngScore = rngScore.Column
' Calculate Score Column Letter.
strScore = Split(rngScore.Address, "$")(1)
End If
Debug.Print "Column Numbers '" & lngName & "' and '" & lngScore & "'."
Debug.Print "Column Letters '" & strName & "' and '" & strScore & "'."
Debug.Print "Name Column Header Address '" & rngName.Address & "'."
Debug.Print "Score Column Header Address '" & rngScore.Address & "'."
With .Parent ' instead of "ThisWorkbook.Worksheets(cSheet)".
'*******************************************************************
' This should demonstrate a case where you don't need the column
' letter (mostly you don't). You should use ".Cells", ".Range" is
' not an option.
'*******************************************************************
' Column Number (lngName)
' Last Row Number calculated using Cells and lngName.
If lngName <> 0 Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, lngName).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, lngName), _
.Cells(lngLR, lngName))
End If
'*******************************************************************
' This is the same as the previous and should demonstrate that
' when you already know the column letter, you have two choices:
' you can use ".Cells" or ".Range".
'*******************************************************************
' Column Letter (strName)
' Last Row Number calculated using Cells and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Cells(.Rows.Count, strName).End(xlUp).Row
' Create a reference to the range First Row to Last Row in
' Name Column.
Set rngName = .Range(.Cells(cFR, strName), _
.Cells(lngLR, strName))
End If
' Last Row Number calculated using Range and strName.
If strName <> "" Then
' Calculate last row in Name Column.
lngLR = .Range(strName & .Rows.Count).End(xlUp).Row
' Create a reference to the range from First Row to Last Row in
' Name Column.
Set rngName = .Range(strName & cFR & ":" & strName & lngLR)
End If
'*******************************************************************
' Since the column letter is more user-friendly, the only use
' I can imagine where you might need it, is to inform the user e.g.
MsgBox "Column '" & strName & "' contains the names and column '" _
& strScore & "' contains the scores.", vbInformation, _
"User Information"
End With
Debug.Print "Last (used) Row in Name Column '" & lngLR & "'."
Debug.Print "Name Range Address '" & rngName.Address & "'."
Debug.Print "Column '" & strName & "' contains the Names and column'" _
& strScore & "' contains the scores."
End With
End Sub
new to VBA so please be gentle.....
I have a script that check for duplicates and inserts a count in a column, this works fine however the sheets are often different so I need to ask the user which column to check for duplicates and which column to insert the count. I've modified the script, but I'm only getting zero's entered into the destination column. I can't see what's going wrong. Any help would be great. Thanks in advance.
Sub LookForDuplicates()
Dim LastRow As Long
Dim column1 As String
'display an input box asking for column
column1 = InputBox( _
"Please enter column to ckeck")
'if no file name chosen, say so and stop
If Len(column1) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
Dim column2 As String
'display an input box asking for column
column2 = InputBox( _
"Please enter column to insert results")
'if no file name chosen, say so and stop
If Len(column2) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
'-------------------------------------------------------
'This is the original version of my script with set columns which works great..... However I need the user to specify the column to checck and also which column the results will be entered.
'LastRow = Range("B" & Rows.Count).End(xlUp).Row
' With Range("E1")
' .FormulaR1C1 = "=COUNTIF(C2,RC[-3])"
' .AutoFill Destination:=Range("E1:E" & LastRow)
' Range("E1").Select
' ActiveCell.FormulaR1C1 = "Duplicates"
'-----------------------------------------------------
LastRow = Range(column1 & Rows.Count).End(xlUp).Row
With Range(column2 & "1")
.FormulaR1C1 = "=COUNTIF(C2,RC[-3])"
.AutoFill Destination:=Range(column2 & "1" & ":" & column2 & LastRow)
Range(column2 & "1").Select
ActiveCell.FormulaR1C1 = "Duplicates"
End With
End Sub
I cannot get this working with the user input variables, apologies if I'm missing something but I can't find any resources on this....
The formula: =COUNTIF($B:$B,B2) works except when in the macro.
I need to add this line to the macro replaced with variables from user input like: =COUNTIF($column1:$column1,column12) but I keep getting syntax errors.
Thanks.
If you are expecting a String/Text value from your input box then you should specify it,
Dim column1 As String
'display an input box asking for column
column1 = InputBox("Please enter column to ckeck", "Range to Check", , , , 2)
Instead of juggling with a String here, why don't you just use the Range object where user can simply click on either full range or one cell in that column you want to check..
Using a range to get the inputbox data: You main issue seems to be setting range to check column in formula.
Option Explicit
Sub LookForDuplicates()
Dim LastRow As Long, StartRow as Long
Dim column1 As Range, column2 As Range
Set column1 = Application.InputBox("Please enter _
column to ckeck", "Range to Check", , , , , , 8)
If column1 Is Nothing Then
MsgBox "No column entered"
Exit Sub
End If
Set column2 = Application.InputBox("Please _
enter column to insert results", _
"Range to Output Results", , , , , , 8)
If column2 Is Nothing Then
MsgBox "No column entered"
Exit Sub
End If
LastRow = Cells(Rows.Count, column1.Column).End(xlUp).Row '--updated here
StartRow = column2.Row '-- here a new code added, assuming that you will have at least one row for column titles
With column2
.FormulaR1C1 = "=COUNTIF(R" & column1.Row _
& "C[-1]:R" & LastRow + 2 & "C[-1],RC[-1])"
.AutoFill Destination:=column2.Resize(LastRow - StartRow, 1)
End With
column2.Offset(-1, 0).FormulaR1C1 = "Duplicates"
End Sub
Output:
Solution if anybody else might find this useful:
The issue was even though column 1 was entered as a Column Reference H for example the COUNTIF function required this as a numeric reference so added an extra variable on the column1 value to the numeric value and modified the formula to suit. All working now:
Dim LastRow As Long
Dim column1 As String
'display an input box asking for column
column1 = InputBox( _
"Please enter column to ckeck")
'if no file name chosen, say so and stop
ColumnNumber = Columns(column1).Column
If Len(column1) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
Dim column2 As String
'display an input box asking for column
column2 = InputBox( _
"Please enter column to insert results")
'if no file name chosen, say so and stop
If Len(column2) = 0 Then
MsgBox "No column entered"
Exit Sub
End If
LastRow = Range(column1 & Rows.Count).End(xlUp).Row
With Range(column2 & "1")
.FormulaR1C1 = "=COUNTIF(C" & ColumnNumber & ",C" & ColumnNumber & ")"
.AutoFill Destination:=Range(column2 & "1" & ":" & column2 & LastRow)
Range(column2 & "1").Select
ActiveCell.FormulaR1C1 = "Duplicates"
End With
End Sub