Im currently working on a code that gets a employee number and replace it with their name in the same cell. It works with a loop that go and look for a match in an hiden sheets.
Problem is for some reason i always get a 1004 error from my Find fonction which i coudnt resolve with all of google for some reason : here's my code:
Sub Employe()
Dim ash As Worksheet
Set ash = ActiveSheet
Dim i As Integer
k = 4
no = 0
nom = ""
nos = ""
For i = 1 To 4 'Goes trough the 4 employee nb input
ash.Select
k = k + 1
no = Cells(k, 3).Value 'Gets the employee number value
If no <> "" Then 'look if loop cell is empty
nos = CStr(no)
Sheets("Liste Employé").Select 'select the hidden sheets (not hidden as of right now we'll get to that other problem later)
Dim foundRng As Range
Set foundRng = Range("A2:A91").Find(nos) 'Go look for the matching number in reference sheets range
If foundRng Is Nothing Then
MsgBox ("Entrer un numéro d'employé valide")
Else
nom = CStr(foundRng)
ash.Select
Cells(k, 3).Value = foundRng 'give the value in original sheet
End If
End If
Next
End Sub
The problem is link to this line :
Set foundRng = Range("A2:A91").Find(nos)
Which returns an 1004 error.
I think it has to do with the value of "foundRng" not resetting each loop but no clue how to fix it.
Thx yall, love
There's no need to select a sheet before using Find (so you can safely hide it with no problem)
Set foundRng = Sheets("Liste Employé").Range("A2:A91").Find(what:=nos, lookAt:=xlWhole)
VLookup might be easier:
Sub Employe()
Dim ash As Worksheet, rngInfo As range, res, c As Range
Set ash = ActiveSheet
Dim i As Long
k = 4
Set rngInfo = Sheets("Liste Employé").Range("A2:A91")
For each c in Range("A4:A8").Cells
If c.Value <> "" Then
'lookup the name from ColB
res = application.vlookup(CStr(c.Value), rngInfo, 2, False)
If Not IsError(res) Then
c.Value = res
Else
MsgBox "Entrer un numéro d'employé valide"
End If
End If
Next
End Sub
Related
The code works "beautifully"(it needs to be cleaned up etc.) but if I delete rows or modify rows in Worksheets("Material For Quotation") and rerun the code it defaults to the max rowcount (1,048,576). I've searched around and read the Microsoft stuff and I cant figure it out. What I am stumped on is that the code should run independent of what's in the worksheet, but the minute I delete or modify the worksheet rowcount doesn't work.
Does anyone have insight?
Sub QuoteToMaterial()
Dim wb As Workbook
Dim ws, wscheck, ws1, ws2 As Worksheet
Dim i, j, k, l As Integer
Dim dict As New Dictionary
Dim Str As String
Dim key As Variant
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Material For Quotation")
i = ws1.Cells(Rows.Count, 2).End(xlUp).row
j = 1
'init dictionary
For j = 2 To i
If dict.Exists(Trim(UCase(ws1.Cells(j, 3).value))) = True Then
dict(Trim(UCase(ws1.Cells(j, 3).value))) = dict(Trim(UCase(ws1.Cells(j, 3).value))) + ws1.Cells(j, 4).value
Else
dict.Add ws1.Cells(j, 3).value, ws1.Cells(j, 4).value
End If
Next j
i = wb.Worksheets.Count
j = 1
For k = 1 To i
Set wscheck = wb.Worksheets(k)
Select Case True
Case wscheck.Name = "Summary"
GoTo Loopiter 'loop iterate
Case wscheck.Name = "Material For Quotation"
GoTo Loopiter
Case wscheck.Name = "Pricing Summary"
GoTo Loopiter
Case wscheck.Name = "Installation 1"
GoTo Loopiter
Case wscheck.Name = "Installation 2"
GoTo Loopiter
Case wscheck.Name = "Inst Worksheet 1"
GoTo Loopiter
Case wscheck.Name = "Inst Worksheet 2"
GoTo Loopiter
Case Else
Set ws = wb.Worksheets(k)
'inserts $ per unit into the right place
For l = 4 To 101
If dict.Exists(ws.Cells(l, 9).value) = True Then
ws.Cells(l, 11).value = dict(ws.Cells(l, 9).value)
End If
Next l
j = j + 1
End Select
Loopiter:
Next k
End Sub
Sorry Guys the answer to this problem is that we ending up putting table formatting on columns 1-4 down to row 1,048,576. So using ws.cells(rows.count,2) goes to the bottom because they are all taken up by a table.
to correct either remove the table formatting and just cell fill to get the look or use the listobject and get the number of filled rows there.
Error in finding last used cell in Excel with VBA
Sorry all I didn't realize the problem until everyone focused on the messy code lol
Thx.
I am working on an Excel document using VBA. This document contains a database with multiple columns, but for simplicity, let's say I have 2 columns:
Column C corresponds to names
Column F corresponds to numbers.
I'm trying to create a macro that checks all the numbers in column F (with a loop). If the number is above 100, then check the adjacent cell in column C. If the name corresponds to a condition (let's say corresponds to John or Tom), then add the value of the number in another sheet. If none of those apply, check the next cell.
My problem is that I can't find a way to define the cells in column C (Creating a variable/object to call the cells or calling directly the adjacent cell).
My code looks like this:
Sub Test1()
Dim rngnumbers, rngnames, MultipleRange As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
Else
End If
End If
Next numb
End Sub
I tried modifying the line:
'If Sheet2.Range("C2") = "John" Or Sheet2.Range("C2") = "Tom" Then'
to something like:
'newname.String = "John" '
But I can't find a way to define newname.
Another idea would be to increment the If statement for the names within the For loop.
Additional note:
I am also not using formulas directly within Excel as I don't want any blank cells or zeros when the if functions are False.
Does this solve your problem - referencing the relevant cell in column C? OFFSET provides a relative reference, in this case look 3 columns to the left of F.
Sub Test1()
Dim rngnumbers As Range, rngnames As Range, MultipleRange As Range, numb As Range
Set rngnumbers = Sheet2.Range("F2:F999")
Set rngnames = Sheet2.Range("C2:C999")
Set MultipleRange = Union(rngnumbers, rngnames)
For Each numb In rngnumbers
If numb.Value >= 100 Then
If numb.Offset(, -3) = "John" Or numb.Offset(, -3) = "Tom" Then
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = numb.Value
End If
End If
Next numb
End Sub
Have you considered SUMIFS instead?
You want something like this?
Sub Test1()
Dim lRow As Long, r As Long
lRow = 1000 'last row in your data
Dim ws As Worksheet
Set ws = Worksheets("List with your data")
For i = 2 To lRow
If ws.Range("F" & i) > 100 Then
If ws.Range("C" & i).Value = "John" Or ws.Range("C" & i).Value = "Tom" Then
Worksheets("Another sheet sheet").Range("A" & r) = Range("C" & i).Value ' r - Row, where we want to enter uor text
r = r + 1 'if you want to put next name on the next row
End If
End If
Next
End Sub
Two Ifs in a Loop
Union Version
Option Explicit
Sub Test1()
Const cFirst As Integer = 2
Const cLast As Integer = 999
Const cCol1 As Variant = "F"
Const cCol2 As Variant = "C"
Const cCol3 As Variant = "I"
Dim i As Integer
Dim rngU As Range
With Sheet2
For i = cFirst To cLast
If IsNumeric(.Cells(i, cCol1)) And .Cells(i, cCol1) >= 100 Then
If .Cells(i, cCol2) = "John" _
Or .Cells(i, cCol2) = "Tom" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, cCol1))
Else
Set rngU = .Cells(i, cCol1)
End If
End If
End If
Next
End With
If Not rngU Is Nothing Then
rngU.Copy Sheet1.Cells(cLast, cCol3).End(xlUp).Offset(1, 0)
Set rngU = Nothing
End If
End Sub
I normally work with arrays:
Sub Test1()
Dim rngnumbers As Excel.Range
Dim arrVals As variant
Dim lngRow As long
Arrvals = Sheet2.Range("C2:F999").value
For Lngrow = lbound(arrvals,1) to ubound(arrvals,1)
If arrvals(lngrow,4) >= 100 Then
If arrvals(lngrow,1)= "John" Or arrvals(lngrow,1) = "Tom" Then '''The problem here is that it only looks at the cell C2 and not the adjacent cell
Sheet1.Range("I999").End(xlUp).Offset(1, 0).Value = arrvals(lngrow,4)
Else
End If
End If
Next lngrow
End Sub
Actually I would probably build an output array as well, but my thumb is tired...
I'm trying to delete hidden Names but with a rule that I choose what hidden Name to delete and what not.
Using the code from Microsoft support I managed to make a list of the names
on a log sheet and added a column that when I enter 1 next to it I want to not delete the name, and when I leave it blank U want it to remove the name.
code from Microsoft support (https://support.microsoft.com/en-us/help/119826/macro-to-remove-hidden-names-in-active-workbook)
here is my code:
Sub clean_names()
Application.ScreenUpdating = False
On Error Resume Next
Set nms = ActiveWorkbook.Names
MsgBox (nms.Count)
For R = 1 To nms.Count
Name_Name = nms(R).Name
Name_Referance = nms(R).RefersTo
'###########ActiveWorkbook.Names(Name_Name).Delete
'ActiveWorkbook.nms(R).Delete
Sheets("LOG").Cells(R + 1, 1).Value = Name_Name
Sheets("LOG").Cells(R + 1, 2).Value = "'" + Name_Referance
'Application.StatusBar = R
Next R
'Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
'================================================================
Sub DelNames()
Dim xName As Variant
Dim Indx As Integer
Dim Vis As Variant
Cells(2, 1).Select
If (ActiveCell = "") Then Exit Sub
Indx = 1
Do
If (ActiveCell.Offset(Indx, 2) = "") Then
xName = ActiveCell.Offset(Indx, 0).Value
If xName.Visible = True Then
Vis = "Visible"
Else
Vis = "Hidden"
End If
xName.Delete
End If
Indx = Indx + 1
Loop While Len(ActiveCell.Offset(Indx, 0))
End Sub
How can i make this code work ?
Try the code below, it will loop thorugh all rows in Column A, check if column C is empty, and will delete that Name from your workbook.
Note: I've commented 5 lines from your original code, since according to your post you don't care if the Names are Visible or not, you want to delete them based on the value in Column C.
Code
Option Explicit
Sub DelNames()
Dim xName As Name
Dim Indx As Long
Dim Vis As Variant
Dim LastRow As Long
With Worksheets("LOG")
If IsEmpty(.Range("A2").Value) Then Exit Sub
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<-- get last row in column A (where you have a NamedRange)
For Indx = 2 To LastRow
If .Range("C" & Indx).Value = "" Then
' set xName with the text entered in column A (as the Named Range Name)
Set xName = ThisWorkbook.Names(.Range("A" & Indx).Value)
' not sure you need the 5 lines with the If criteria below so I Commented them for now
'If xName.Visible = True Then
' Vis = "Visible"
'Else
' Vis = "Hidden"
'End If
xName.Delete
End If
Next Indx
End With
End Sub
I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub
I have column A with staff ids and hours worked in column K.
I would like if a staff id appears more than once to add hours worked and put the result in another column corresponding to the first instance of that staff id and the duplicates being 0.
This is for a monthly report and there may be over 2k records at any point.
As everyone else said, a Pivot Table really is the best way. If you're unsure how to use a PivotTable or what it's good for, refer to this SO post where I explain in detail.
Anyway, I put together the below VBA function to help get you started. It's by no means the most efficient approach; it also makes the following assumptions:
Sheet 1 has all the data
A has Staff Id
B has Hours
C is reserved for Total Hours
D will be available for processing status output
This of course can all be changed very easily by altering the code a bit. Review the code, it's commented for you to understand.
The reason a Status column must exist is to avoid processing a Staff Id that was already processed. You could very alter the code to avoid the need for this column, but this is the way I went about things.
CODE
Public Sub HoursForEmployeeById()
Dim currentStaffId As String
Dim totalHours As Double
Dim totalStaffRows As Integer
Dim currentStaffRow As Integer
Dim totalSearchRows As Integer
Dim currentSearchRow As Integer
Dim staffColumn As Integer
Dim hoursColumn As Integer
Dim totalHoursColumn As Integer
Dim statusColumn As Integer
'change these to appropriate columns
staffColumn = 1
hoursColumn = 2
totalHoursColumn = 3
statusColumn = 4
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
totalStaffRows = Sheet1.Cells(Rows.Count, staffColumn).End(xlUp).Row
For currentStaffRow = 2 To totalStaffRows
currentStaffId = Cells(currentStaffRow, staffColumn).Value
'if the current staff Id was not already processed (duplicate record)
If Not StrComp("Duplicate", Cells(currentStaffRow, statusColumn).Value, vbTextCompare) = 0 Then
'get this rows total hours
totalHours = CDbl(Cells(currentStaffRow, hoursColumn).Value)
'search all subsequent rows for duplicates
totalSearchRows = totalStaffRows - currentStaffRow + 1
For currentSearchRow = currentStaffRow + 1 To totalSearchRows
If StrComp(currentStaffId, Cells(currentSearchRow, staffColumn), vbTextCompare) = 0 Then
'duplicate found: log the hours worked, set them to 0, then mark as Duplicate
totalHours = totalHours + CDbl(Cells(currentSearchRow, hoursColumn).Value)
Cells(currentSearchRow, hoursColumn).Value = 0
Cells(currentSearchRow, statusColumn).Value = "Duplicate"
End If
Next
'output total hours worked and mark as Processed
Cells(currentStaffRow, totalHoursColumn).Value = totalHours
Cells(currentStaffRow, statusColumn).Value = "Processed"
totalHours = 0 'reset total hours worked
End If
Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub
BEFORE
AFTER
Here is the solution for the data table located in range A1:B10 with headers and results written to column C.
Sub Solution()
Range("c2:c10").Clear
Dim i
For i = 2 To 10
If WorksheetFunction.SumIf(Range("A1:a10"), Cells(i, 1), Range("C1:C10")) = 0 Then
Cells(i, "c") = WorksheetFunction.SumIf( _
Range("A1:a10"), Cells(i, 1), Range("B1:B10"))
Else
Cells(i, "c") = 0
End If
Next i
End Sub
Try below code :
Sub sample()
Dim lastRow As Integer, num As Integer, i As Integer
lastRow = Range("A65000").End(xlUp).Row
For i = 2 To lastRow
num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0)
If i = num Then
Cells(i, 3) = WorksheetFunction.SumIf(Range("A1:A" & lastRow), Cells(i, 1), Range("B1:B" & lastRow))
Else
Cells(i, 1).Interior.Color = vbYellow
End If
Next
End Sub
BEFORE
AFTER
Below code identifies duplicate value in a column and highlight with red. Hope this might be of some help.
iLastRow = Cells(chosenExcelSheet.Rows.Count, 1).End(xlUp).Row 'Determine the last row to look at
Set rangeLocation = Range("A1:A" & iLastRow)
'Checking if duplicate values exists in same column
For Each myCell In rangeLocation
If WorksheetFunction.CountIf(rangeLocation, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3'Highlight with red Color
Else
myCell.Interior.ColorIndex = 2'Retain white Color
End If
Next
Sub SelectColoredCells()
Dim rCell As Range
Dim lColor As Long
Dim rColored As Range
'Select the color by name (8 possible)
'vbBlack, vbBlue, vbGreen, vbCyan,
'vbRed, vbMagenta, vbYellow, vbWhite
lColor = RGB(156, 0, 6)
'If you prefer, you can use the RGB function
'to specify a color
'Default was lColor = vbBlue
'lColor = RGB(0, 0, 255)
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = lColor Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
If rColored Is Nothing Then
MsgBox "No cells match the color"
Else
rColored.Select
MsgBox "Selected cells match the color:" & _
vbCrLf & rColored.Address
End If
Set rCell = Nothing
Set rColored = Nothing
End Sub
this highlights the duplicates