I am writing a procedure to generate a number of named ranges from values in a worksheet, with the cell to be named in column C and the name to be assigned in the adjacent cell in column D. All variations I've tried to reference these two cells as ranges returned errors. While this procedure will be used only once to generate these names, I'd like to determine the correct syntax so I'll be able to reference ranges for other purposes in the future.
I have a temporary ActiveX CommandButton that calls the following code (just referencing two rows for now for testing purposes):
Private Sub CommandButton1_Click()
Call SetRangeNames(38, 39)
End Sub
I placed the SetRangeNames procedure in a module based on recommendations in posts I've seen elsewhere. The two lines of code returning errors are indicated by a comment within the procedure code, and all of the variations I've tried (with the errors they return) follow that. I placed a MsgBox call in the proc to see how it was rendering the cell references generated. It displays:
rangeNameValueCellAddress = "C38"; namedRangeCellAddress = "D38"
or
rangeNameValueCellAddress = "C39"; namedRangeCellAddress = "D39"
Here's one varation of the proc:
Public Sub SetRangeNames(startRow As Integer, endRow As Integer)
Dim theRange As Range
Dim currentRow As Integer
Dim currentName As String
Dim rangeNameValueCellAddress As String
Dim namedRangeCellAddress As String
For currentRow = startRow To endRow
rangeNameValueCellAddress = """D" & Trim(Str(currentRow) & """")
namedRangeCellAddress = """C" & Trim(Str(currentRow) & """")
MsgBox ("rangeNameValueCellAddress = " & rangeNameValueCellAddress & _
"; namedRangeCellAddress = " & namedRangeCellAddress)
'MsgBox displays: rangeNameValueCellAddress = "C38"; namedRangeCellAddress = "D38"
' or: rangeNameValueCellAddress = "C39"; namedRangeCellAddress = "D39"
'*** The following two statements return errors:
Set theRange = ThisWorkbook.Worksheets(ActiveSheet).Range(namedRangeCellAddress)
currentName = ThisWorkbook.Worksheets(ActiveSheet).Range(rangeNameValueCellAddress).Value2
ActiveWorkbook.Names.Add Name:=currentName, RefersTo:=theRange
Next currentRow
End Sub
Here are the variations I tried ("SYSProjectData" is both the name and CodeName and Name of the worksheet I am working with):
Set theRange = SYSProjectData.Range(namedRangeCellAddress)
currentName = SYSProjectData.Range(rangeNameValueCellAddress).Value2
Returns: "Application-defined or object-defined error"
Set theRange = ThisWorkbook.SYSProjectData.Range(namedRangeCellAddress)
currentName = ThisWorkbook.SYSProjectData.Range(rangeNameValueCellAddress).Value2
Returns: "Object doesn't support this property or method"
Set theRange = ThisWorkbook.ActiveSheet.Range(namedRangeCellAddress)
currentName = ThisWorkbook.ActiveSheet.Range(rangeNameValueCellAddress).Value2
Returns: "Application-defined or object-defined error"
Set theRange = ActiveSheet.Range(namedRangeCellAddress)
currentName = ActiveSheet.Range(rangeNameValueCellAddress).Value2
Returns: "Application-defined or object-defined error"
Set theRange = ThisWorkbook.Worksheets(SYSProjectData).Range(namedRangeCellAddress)
currentName = ThisWorkbook.Worksheets(SYSProjectData).Range(rangeNameValueCellAddress).Value2
Returns: "Type mismatch"
Set theRange = ThisWorkbook.Worksheets("SYSProjectData").Range(namedRangeCellAddress)
currentName = ThisWorkbook.Worksheets("SYSProjectData").Range(rangeNameValueCellAddress).Value2
Returns: "Application-defined or object-defined error"
Set theRange = ThisWorkbook.Sheets(SYSProjectData).Range(namedRangeCellAddress)
currentName = ThisWorkbook.Sheets(SYSProjectData).Range(rangeNameValueCellAddress).Value2
Returns: "Type mismatch"
Set theRange = ThisWorkbook.Sheets("SYSProjectData").Range(namedRangeCellAddress)
currentName = ThisWorkbook.Sheets("SYSProjectData").Range(rangeNameValueCellAddress).Value2
Returns: "Application-defined or object-defined error"
Set theRange = ThisWorkbook.Sheets(ActiveSheet).Range(namedRangeCellAddress)
currentName = ThisWorkbook.Sheets(ActiveSheet).Range(rangeNameValueCellAddress).Value2
Returns: "Type mismatch"
Set theRange = ThisWorkbook.Worksheets(ActiveSheet).Range(namedRangeCellAddress)
currentName = ThisWorkbook.Worksheets(ActiveSheet).Range(rangeNameValueCellAddress).Value2
Returns: "Type mismatch"
Can anyone tell me what I'm doing wrong?
Thanks!
You should be able to do something like this:
Public Sub SetRangeNames(startRow As Integer, endRow As Integer)
Dim currentRow As Long 'Long not Integer (always safer)
For currentRow = startRow To endRow
With ThisWorkbook.Sheets("SYSProjectData")
'worksheets Parent is the containing workbook
.Parent.Names.Add Name:=.Cells(currentRow, "D"), _
RefersTo:=.Cells(currentRow, "C")
End With
Next currentRow
End Sub
Heres your code, commented where there are issues
'Public Sub SetRangeNames(startRow As Integer, endRow As Integer)
' Better to use Long
Public Sub SetRangeNames(startRow As Long, endRow As Long)
Dim theRange As Range
Dim currentRow As Long ' Integer
Dim currentName As String
Dim rangeNameValueCellAddress As String
Dim namedRangeCellAddress As String
For currentRow = startRow To endRow
'rangeNameValueCellAddress = """D" & Trim(Str(currentRow) & """")
' Don't include " in the string value.
' No need for Trim(Str(
rangeNameValueCellAddress = "D" & currentRow
'namedRangeCellAddress = """C" & Trim(Str(currentRow) & """")
namedRangeCellAddress = "C" & currentRow
MsgBox ("rangeNameValueCellAddress = " & rangeNameValueCellAddress & _
"; namedRangeCellAddress = " & namedRangeCellAddress)
'*** The following two statements return errors:
'Set theRange = ThisWorkbook.Worksheets(ActiveSheet).Range(namedRangeCellAddress)
' ActiveSheet is already a worksheetsheet
Set theRange = ActiveSheet.Range(namedRangeCellAddress)
currentName = ActiveSheet.Range(rangeNameValueCellAddress).Value2
ActiveWorkbook.Names.Add Name:=currentName, RefersTo:=theRange
Next currentRow
End Sub
Here's an alternate method, see inline comments
Private Sub CommandButton2_Click()
SetRangeNames2 ActiveSheet.Range("C8")
End Sub
Public Sub SetRangeNames2(startCell As Range)
Dim Nm As Name
Dim Dat As Variant
Dim i As Long
With startCell.Worksheet
' Copy data to Variant array, for speed
Dat = .Range(startCell, .Cells(.Rows.Count, startCell.Column).End(xlUp)).Resize(, 2).Value2
' Loop the array
For i = 1 To UBound(Dat, 1)
' Check if name already exists
Set Nm = Nothing
On Error Resume Next
Set Nm = .Names(Dat(i, 2))
On Error GoTo 0
If Nm Is Nothing Then
' Add name
.Parent.Names.Add Name:=Dat(i, 2), RefersTo:=.Range(Dat(i, 1))
Else
' Name Already exists, update it
Nm.RefersToRange = .Range(Dat(i, 1))
End If
Next
End With
End Sub
Sorry for the delay in posting this. This is what I ended up with...
Public Sub SetRangeNames(strNamedRangeColumn As String, strNameSourceColumn As String, startRow As Long, endRow As Long)
Dim currentRow As Long
Dim rngNameSourceCell As Range
Dim rngNamedRangeCell As Range
Dim strNameSourceCellAddress As String
Dim strNamedRangeCellAddress As String
Dim strNameSourceCellValue As String
Dim strNamedRangeCellValue As String
Dim strRangeValueError As String
strRangeValueError = ""
strNamedRangeColumn = Trim(UCase(strNamedRangeColumn))
strNameSourceColumn = Trim(UCase(strNameSourceColumn))
If Len(strNamedRangeColumn) > 1 Then
MsgBox ("ERROR: The value given for the named range column, """ & strNamedRangeColumn & _
","" was longer than one character.")
Exit Sub
ElseIf Len(strNameSourceColumn) > 1 Then
MsgBox ("ERROR: The value given for the name source column, """ & strNameSourceColumn & _
","" was longer than one character.")
Exit Sub
ElseIf strNamedRangeColumn = "" Then
MsgBox ("ERROR: The value given for the named range column was longer than one character.")
Exit Sub
ElseIf strNameSourceColumn = "" Then
MsgBox ("ERROR: The value given for the name source column was longer than one character.")
Exit Sub
ElseIf Asc(strNamedRangeColumn) < 65 Or Asc(strNamedRangeColumn) > 90 Then
MsgBox ("ERROR: The value given for the named range column, """ & strNamedRangeColumn & _
","" was not a letter.")
Exit Sub
ElseIf Asc(strNameSourceColumn) < 65 Or Asc(strNameSourceColumn) > 90 Then
MsgBox ("ERROR: The value given for the name source column, """ & strNameSourceColumn & _
","" was not a letter.")
Exit Sub
End If
For currentRow = startRow To endRow
strNameSourceCellAddress = strNameSourceColumn & Trim(str(currentRow))
strNamedRangeCellAddress = strNamedRangeColumn & Trim(str(currentRow))
Set rngNameSourceCell = Range(strNameSourceCellAddress)
Set rngNamedRangeCell = Range(strNamedRangeCellAddress)
strNameSourceCellValue = Trim(rngNameSourceCell.Value)
If IsEmpty(rngNameSourceCell) Or Len(strNameSourceCellValue) > 0 Then
strRangeValueError = "Source cell " & strNameSourceCellAddress & " was empty."
End If
If Not (Application.WorksheetFunction.IsText(rngNameSourceCell.Value)) Then
If Len(strRangeValueError) > 0 Then
strRangeValueError = vbCrLf & strRangeValueError
End If
strRangeValueError = strRangeValueError & "Source cell " & strNameSourceCellAddress & _
" contained the not-text value """ & strNameSourceCellValue & """."
End If
If Len(strRangeValueError) > 0 Then
MsgBox (strRangeValueError)
Exit Sub
End If
ThisWorkbook.sheets("mySheetName").Parent.Names.Add Name:=.Cells(currentRow, strNameSourceColumn), _
RefersTo:=.Cells(currentRow, strNamedRangeColumn)
Next currentRow
End Sub
Called as follows...
Private Sub btnGenerateRangeNames_Click()
Call SetRangeNames("C", "E", 8, 11)
' etc.
End Sub
Thanks for your help!
Related
I have two global variables ErrorMsg and SectionName. What I want my macro to do is run through the code and if ErrorMsg is assigned a value, I want it to list the SectionName and then the ErrorMsg that was generated within that section. There are cases where ErrorMsg could appear in multiple different SectionNames thats why I want it to be labeled which Section generated the ErrorMsg.
There will be cases where there are more than two values for ErrorMsg so I need the macro to recognize all the values of ErrorMsg and SectionName list them.
So if errors are generated in lines wavelength_col = GetColumnIndex(ws, "Wavelength (nm)") and power_value = Getdata(ws, sysrow, power_col)
Then the output in With logsht should look like this with each new Section font bolded.
Complete with Error - Section: Wavelength - Wavelength column index could not be found, Section: Power - data could not be found
Here are the functions I mentioned above.
Global ErrorMsg As String, SectionName As String
Sub Main
Dim cell As Range, ws As Worksheet, sysnum As String, sysrow As Integer, wb As Workbook, logsht As Worksheet
Set wb = ActiveWorkbook
Set ws = ActiveWorksheet
Set logsht = wb.Worksheets("Log Sheet")
For Each cell In ws.Range("E2", ws.cells(ws.Rows.Count, "E").End(xlUp)).cells
sysnum = cell.Value
sysrow = cell.row
power_col = GetColumnIndex(ws, "Power (mW)")
power_value = GetJiraData(ws, sysrow, power_col)
Dim begincell As Long
With logsht
begincell = .cells(Rows.Count, 1).End(xlUp).row
.cells(begincell + 1, 2).Value = sysnum
.cells(begincell + 1, 2).Font.Bold = True
If Not ErrorMsg = "" Then
.cells(begincell + 1, 3).Value = "Complete with Erorr - " & ErrorMsg
.cells(begincell + 1, 3).Font.Bold = True
.cells(begincell + 1, 3).Interior.Color = vbRed
Else
.cells(begincell + 1, 3).Value = "Completed without Errors"
.cells(begincell + 1, 3).Font.Bold = True
.cells(begincell + 1, 3).Interior.Color = vbGreen
End If
End With
Next cell
End Sub
Sub Wavelength()
Dim wavelength_col As Long, wavelength_value As Double
SectionName = "Wavelength"
On Error GoTo errormessage
wavelength_col = GetColumnIndex(ws, "Wavelength (nm)")
wavelength_value = Getdata(ws, sysrow, wavelength_col)
Exit Sub
errormessage:
ErrorMsg = ErrorMsg
End Sub
Sub Power()
Dim power_col As Long, power_value As Double
SectionName = "Power"
On Error GoTo errormessage
power_col = GetColumnIndex(ws, "Average Power (mW)")
power_value = Getdata(ws, sysrow, power_col)
Exit Sub
errormessage:
ErrorMsg = ErrorMsg
End Sub
Function GetColumnIndex(sht As Worksheet, colname As String) As Double
Dim paramname As Range
Set paramname = sht.Range("A1", sht.cells(2, sht.Columns.Count).End(xlToLeft)).cells.Find(What:=colname, LookAt:=xlWhole, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=True)
If Not paramname Is Nothing Then
GetColumnIndex = paramname.column
ElseIf paramname Is Nothing Then '
ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", ", ") & colname & " column index could not be found"
End If
End Function
Function Getdata(sht As Worksheet, WDrow As Long, parametercol As Long) As Variant
Getdata = sht.cells(WDrow, parametercol)
If Getdata = -999 Then
ElseIf Getdata = Empty Then
ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", ", ") & "data could not be found"
End If
End Function
first of all, there are several things wrong in your code.
Just to name a few;
your Power() sub uses ws as a WorkSheet object yet they are not declared as Global under the Main method nor are they used as parameters for the sub and hence will not be available? Same applies for Wavelength.
Power() and Wavelenght() both produce a variable yet you do not seem to do anything with those values?
But alas, for the solution;
What you can do is add a ClassModule to your project and give it below fields and name it 'ErrorState'
Option Explicit
Public ErrMsg As String
Public ErrNumber As Long
Public SectionName As String 'suggest to use 'MethodName' but your pick
Then in your CodeModule declare a new Collection as a a Global collection
Global Errors As New Collection
Then add a Method (a Sub if you wish) that adds the error to the collection.
Private Sub AddError(message As String, number As Long, method As String)
Dim error As New ErrorState
error.ErrMsg = message
error.SectionName = method
error.ErrNumber = number
Errors.Add error
End Sub
Add the above correctly to your ErrorHandling as per below example
Sub Power(sht As Worksheet, sysrow As Long)
On Error GoTo ErrorExit
Err.Raise (13) 'you can remove this, this is just to trigger an Error
Dim power_col As Long, power_value As Double
power_col = GetColumnIndex(sht, "Average Power (mW)")
power_value = Getdata(sht, sysrow, power_col)
Exit Sub
ErrorExit:
AddError Err.Description, Err.number, "Power"
End Sub
So your complete code would look like the below (I have simplified the Main method, but I'm sure you get the picture)
Global Errors As New Collection
Private Sub AddError(message As String, number As Long, method As String)
Dim error As New ErrorState
error.ErrMsg = message
error.SectionName = method
error.ErrNumber = number
Errors.Add error
End Sub
Sub Main()
Set Errors = New Collection
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = ActiveSheet
Wavelength ws, 1
Power ws, 1
Index = GetColumnIndex(ws, "SomeColum")
Data = Getdata(ws, 1, 1)
For Each e In Errors
Debug.Print e.SectionName, e.ErrMsg, e.ErrNumber
Next
End Sub
Sub Wavelength(sht As Worksheet, sysrow As Long)
On Error GoTo ErrorExit
Dim wavelength_col As Long, wavelength_value As Double
wavelength_col = GetColumnIndex(sht, "Wavelength (nm)")
wavelength_value = Getdata(sht, sysrow, wavelength_col) 'do you need to do anything with this value?
Exit Sub
ErrorExit:
AddError Err.Description, Err.number, "Wavelength"
End Sub
Sub Power(sht As Worksheet, sysrow As Long)
On Error GoTo ErrorExit
Dim power_col As Long, power_value As Double
power_col = GetColumnIndex(sht, "Average Power (mW)")
power_value = Getdata(sht, sysrow, power_col) 'do you need to do anything with this value?
Exit Sub
ErrorExit:
AddError Err.Description, Err.number, "Power"
End Sub
Function GetColumnIndex(sht As Worksheet, colname As String) As Double
Dim paramname As Range
Set paramname = sht.Range("A1", sht.Cells(2, sht.Columns.Count).End(xlToLeft)).Cells.Find(What:=colname, LookAt:=xlWhole, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=True)
If Not paramname Is Nothing Then
GetColumnIndex = paramname.Column
Else
AddError Trim(colname & " column index could not be found"), 0, "GetColumnIndex"
End If
End Function
Function Getdata(sht As Worksheet, WDrow As Long, parametercol As Long) As Variant
Getdata = sht.Cells(WDrow, parametercol)
If Getdata = -999 Then
'do something
ElseIf IsEmpty(Getdata) Then
AddError "data could not be found", 0, "Getdata"
End If
End Function
I have an Excel worksheet with 20K rows like this:
header1
header2
1
P
2
P
3
P
4
Q
5
R
6
R
7
R
8
R
9
S
10
S
I want a VBA code to delete the rows containing duplicates, but keep the first and last row of the duplicates. The result should be like this:
header1
header2
1
P
3
P
4
Q
5
R
8
R
9
S
10
S
I have modified the following code found here to do just that, but every time I have to manually select the range containing the duplicates in column header2.
Sub Delete_Dups_Keep_Last_v2()
Dim SelRng As Range
Dim Cell_in_Rng As Range
Dim RngToDelete As Range
Dim SelLastRow As Long
Application.DisplayAlerts = False
Set SelRng = Application.InputBox("Select cells", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
For Each Cell_in_Rng In SelRng
If Cell_in_Rng.Row < SelLastRow Then
If Cell_in_Rng.Row > SelRng.Row Then
If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
'this value exists again in the range
If RngToDelete Is Nothing Then
Set RngToDelete = Cell_in_Rng
Else
Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
End If
End If
End If
End If
Next Cell_in_Rng
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
End Sub
Another code found here by user A.S.H. automates the manual selection and speed by using Dictionary, but fails to produce the wanted result.
Sub keepFirstAndLast()
Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim a As Range
For Each a In Sheet1.Range("B2", Sheet1.Range("B999999").End(xlUp))
If Not dict.Exists(a.Value2) Then
dict(a.Value2) = 0 ' first appearence, dont save the row
Else
' if last observed occurrence was a duplicate, add it to deleted range
If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
End If
Next
toDelete.Delete
End Sub
Simple solution:
Sub KeepFirstLast()
Application.ScreenUpdating = False
Dim lastRow As Long
lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
Dim x As Long
Dim currentValue As String
For i = lastRow To 2 Step -1
If i = 2 Then
Application.ScreenUpdating = True
Exit For
End If
currentValue = Sheets(1).Cells(i, 2).Value
x = i - 1
Do While Sheets(1).Cells(x, 2).Value = currentValue And Sheets(1).Cells(x - 1, 2).Value = currentValue
Sheets(1).Rows(x).Delete
x = x - 1
Loop
i = x + 1
Next i
Application.ScreenUpdating = True
End Sub
You may benefit from SpecialCells to select those rows based on formula:
Sub test()
Dim LR As Long 'last row
Dim LC As Long 'last column
Dim SR As Long 'starting row
Dim rng As Range
Set rng = Range("A1") 'change this to TOP LEFT CELL OF YOUR DATA
SR = rng.Row
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column 'last column used
'we add new column with formula to delete
With Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1))
.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End With
'clear formula
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1)).Clear
Set rng = Nothing
End Sub
[![enter image description here][1]][1]
The tricky part is here:
.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
First line will create and IF(OR) formula to check if the row must be deleted or not. It will return x if not, else 0
Second line will delete entire rows only if it contains a number (zero)
[1]: https://i.stack.imgur.com/UlhtI.gif
This can also be accomplished using Power Query, available in Windows Excel 2010+ and Excel 365 (Windows or Mac)
To use Power Query
Select some cell in your Data Table
Data => Get&Transform => from Table/Range or from within sheet
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
//change next line to your actual table name in your worksheet
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"header1", Int64.Type}, {"header2", type text}}),
//Group by header2
// then return the first and last table rows if there is more than a single row
#"Grouped Rows" = Table.Group(#"Changed Type", {"header2"}, {
{"header1", each if Table.RowCount(_) = 1 then _
else Table.FromRecords({Table.First(_),Table.Last(_)}),
type table[header1=Int64.Type, header2=text]}
}),
//expand the subtables and set the column order
#"Expanded header1" = Table.ExpandTableColumn(#"Grouped Rows", "header1", {"header1"}),
#"Reordered Columns" = Table.ReorderColumns(#"Expanded header1",{"header1", "header2"})
in
#"Reordered Columns"
Keep First and Last In Sorted Range
Option Explicit
Sub DeleteNotFirstNorLast()
Const ProcName As String = "DeleteNotFirstNorLast"
Dim RowsDeleted As Boolean ' to inform
On Error GoTo ClearError ' enable error trapping
' Constants (adjust!)
Const FirstCellAddress As String = "A1"
Const CriteriaColumnIndex As Long = 2
Const Criteria As String = "#$%"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Application.ScreenUpdating = False
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the table range.
Dim trg As Range: Set trg = RefCurrentRegion(ws.Range(FirstCellAddress))
' Write an ascending integer sequence adjacent to the right
' of the table range.
AppendColumnOfAscendingIntegers trg
' Include this helper column to the table range.
Set trg = trg.Resize(, trg.Columns.Count + 1)
' Reference the criteria column range.
Dim crg As Range: Set crg = trg.Columns(CriteriaColumnIndex)
' It is assumed that the criteria column is already sorted favorably.
' If not, you could do something like the following:
' Sort the table range by the criteria column ascending.
'trg.Sort crg, xlAscending, , , , , , xlYes
' Write the data rows (no headers) count to a variable.
Dim drCount As Long: drCount = trg.Rows.Count - 1
' Reference the criteria column data range (headers excluded).
Dim cdrg As Range: Set cdrg = crg.Resize(drCount).Offset(1)
' Write the values from the criteria column data range to an array.
Dim cData As Variant: cData = GetRange(cdrg)
' Replace the unwanted values in the array with the criteria.
KeepFirstAndLastInColumn cData
' Write the (modified) values from the array back to the range.
cdrg.Value = cData
' Reference the table data range (no headers).
Dim tdrg As Range: Set tdrg = trg.Resize(drCount).Offset(1)
' Filter the table range in the criteria column by the criteria.
trg.AutoFilter CriteriaColumnIndex, Criteria
' Attempt to reference the table data visible (filtered) range.
Dim tdvrg As Range
On Error Resume Next ' defer error trapping
Set tdvrg = tdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo ClearError ' re-enable error trapping
' Remove the filter.
ws.AutoFilterMode = False
' Attempt to delete the table data visible range.
If Not tdvrg Is Nothing Then
tdvrg.Delete xlShiftUp
RowsDeleted = True
End If
' Reference the helper column.
Dim hrg As Range: Set hrg = trg.Columns(trg.Columns.Count)
' Sort the table range by the helper column ascending.
trg.Sort hrg, xlAscending, , , , , , xlYes
' Clear the helper column.
hrg.Clear
SafeExit:
Application.ScreenUpdating = True ' to see any changes while reading message
' Inform.
If RowsDeleted Then
MsgBox "Rows deleted.", vbInformation, ProcName
Else
MsgBox "Nothing deleted.", vbExclamation, ProcName
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with the first cell
' of a range and ending with the last cell of the first cell's
' Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegion"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
- FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes an ascending integer sequence adjacent to the right
' of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AppendColumnOfAscendingIntegers( _
ByVal trg As Range, _
Optional ByVal FirstInteger As Long = 1)
Const ProcName As String = "AppendColumnOfAscendingIntegers"
On Error GoTo ClearError
With trg
With .Resize(, 1).Offset(, .Columns.Count)
.Value = .Worksheet.Evaluate("ROW(" & CStr(FirstInteger) & ":" _
& CStr(FirstInteger + .Rows.Count - 1) & ")")
End With
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('trg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal trg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If trg.Rows.Count + trg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = trg.Value
GetRange = Data
Else ' multiple cells
GetRange = trg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In the first column of a 2D one-based array of sorted values,
' keeps the first and last occurrence of each value and replaces
' the remaining occurrences with a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub KeepFirstAndLastInColumn( _
ByRef cData As Variant, _
Optional ByVal Criteria As String = "#$%")
Const ProcName As String = "KeepFirstAndLastInColumn"
On Error GoTo ClearError
Dim OldString As String: OldString = CStr(cData(1, 1))
Dim r As Long
Dim cr As Long
Dim FirstRow As Long
Dim NewString As String
For r = 2 To UBound(cData, 1)
NewString = CStr(cData(r, 1))
If NewString = OldString Then
If FirstRow = 0 Then
FirstRow = r
End If
Else
If FirstRow > 0 Then
For cr = FirstRow To r - 2
cData(cr, 1) = Criteria
Next cr
FirstRow = 0
End If
OldString = NewString
End If
Next r
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I got this code from someone who helped me convert this excel formula to vba. The Excel formula is:
=INDEX('C:\Users\Desktop\[Backlog.xlsx]backlog1'!$J:$J,MATCH(A3,'C:\Users\Desktop\[Backlog.xlsx]backlog1'!$W:$W,0))
The code is:
SetAttr "C:\Users\Desktop\Backlog.xlsx", vbNormal
Dim Backlog As Workbook
Dim bcklog1 As Worksheet
Set Backlog = Workbooks.Open(Filename:="C:\Users\Desktop\Backlog.xlsx", UpdateLinks:=0)
Set bcklog1 = Backlog.Worksheets("backlog1")
Dim result As Variant, test As Variant
Dim frml As Variant, match_row As Variant
frml = "match(A2, " & bcklog1.Range("W:W").Address(external:=True) & ", 0)"
Debug.Print frml
match_row = Evaluate(frml)
Debug.Print match_row
frml = "index(" & bcklog1.Range("J:J").Address(external:=True) & ", " & frml & ")"
Debug.Print frml
result = Evaluate(frml)
test = Application.WorksheetFunction.Index(bcklog1.Range("J:J"), match_row, 1)
Debug.Print test`
I keep getting an error mismatch, I have changed the variables all to Variant and still no success. The sub should use index/match to find values between two different workbooks. Some values will not be found resulting in an "error", which is what I also want to find, the error will represent things I need to focus on. The results should appear in column F:F. I have been stuck on this for a while now, any help is appreciated.
EDIT - updated to use a loop
I'd do it this way...
Sub test()
Dim Backlog As Workbook
Dim bcklog1 As Worksheet
Set Backlog = Workbooks.Open(Filename:="C:\Users\Desktop\Backlog.xlsx", UpdateLinks:=0)
Set bcklog1 = Backlog.Worksheets("backlog1")
Dim m, test, c
' adjust following range as needed
For each c in ActiveSheet.Range("A2:A200").Cells
v = c.Value
If Len(v) > 0 then
'note no "worksheetfunction" or "no match" will raise an error
m = Application.Match(v, bcklog1.Range("W:W"), 0)
'instead we test for no match here...
If Not IsError(m) Then
test = bcklog1.Range("J:J").Cells(m).Value
'Debug.Print test
c.offset(0, 5).Value = test 'populate colF
End If
End If 'cell has a value
Next c
End Sub
If match_row evaluates to an error type (Error 2042 if the match is not found), the assignment to test = Application.WorksheetFunction.Index(... will fail, because the right-side of the assignment statement cannot evaluate, because you're passing the Error 2042 to the Index function.
If Not IsError(match_row) Then
test = Application.WorksheetFunction.Index(bcklog1.Range("J:J"), match_row, 1)
Else
MsgBox "something"
End If
Here is a way that does all of the comparisons an puts them in column F.
This method is interesting from a technical perspective because it uses no VBA loops at all:
Public Sub excelhero()
Const BACKLOG_WB = "C:\Users\Desktop\Backlog.xlsx"
Const BACKLOG_WS = "backlog1"
Dim n&, ws As Worksheet
Set ws = Workbooks.Open(BACKLOG_WB, 0).Worksheets(BACKLOG_WS)
With ThisWorkbook.ActiveSheet
n = .Cells(.Rows.Count, "a").End(xlUp).Row
.Range("f2:f" & n) = ws.Evaluate("transpose(transpose(index(j:j,n(if(1,match([" & .Parent.Name & "]" & .Name & "!a2:a" & n & ",w:w,))))))")
End With
ws.Parent.Close
End Sub
Can anyone Please help resolve an issue with ReferToRange in my code. I have attached an example.
I am getting a runtime error 1041 application defined or object defined error when the MAIN is called.
I am linking a combobox listfillrange to 3 named ranges depending on the value of a cell. The three ranges are dynamic(have an offset formula).
the combobox is a different sheet than the named ranges
Please help
Sub MAIN()
Dim PT As Range
Dim i As Long
With Sheet3 ' Unique SPP
setNames .Range("a6")
Set PT = .Range("b1")
i = 1
Do Until PT = ""
If .Range("a1").Value = PT.Value Then
On Error Resume Next
Sheet1.ComboBox1.ListFillRange = ThisWorkbook.Names("view" & i).Name
If Err.Number = 1004 Then
MsgBox "not defined name: view" & i
ElseIf Err.Number <> 0 Then
MsgBox "unexpected error: " & Err.Description
End If
On Error GoTo 0
End If
i = i + 1
Set PT = PT.Offset(0, 1)
Loop
End With
End Sub
Sub setNames(theTopLeft As Range)
Dim theName As Name
Dim nameStr As String
Dim theRng As Range
Dim i As Long
Application.DisplayAlerts = False
theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
Bottom:=False, Right:=False
Application.DisplayAlerts = True
For Each theName In ThisWorkbook.Names
With theName.RefersToRange.Value
For i = .Cells.Count To 1 Step -1
If .Cells(i) <> "" Then Exit For
Next
End With
If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
Next
End Sub
It seems to me that your code is a bit more complicated than necessary. So if I'm understanding correctly what you're trying to do, this should fit the bill.
Sub MAIN()
Dim rC As Range
Dim rD As Range
Dim i As Long
Dim s As String
On Error GoTo errTrap
With Sheet3 'change to suit
s = .Range("a1") 'heading to find
Set rD = .Range("A6", .Cells.SpecialCells(xlCellTypeLastCell)) 'data row 6 and down
Set rD = rD.Resize(, 3) '1st 3 columns only, change if required
i = Application.Match(s, rD.Rows(1).Cells, 0) 'find heading
Set rC = rD.Columns(i).Offset(1).Cells 'drop heading from column
Set rC = .Range(rC(1), .Cells(.Rows.Count, rC.Column).End(xlUp)) 'to end of data
' if column contains data, fill combo
If rC(1).Row > rD.Row Then Sheet1.ComboBox1.ListFillRange = .Name & "!" & rC.Address
End With
Exit Sub
errTrap:
If Err.Number = 13 Then
MsgBox "heading not found: " & s
Else
MsgBox "unexpected error: " & Err.Description
End If
End Sub