The following macro is created to match employee names to badge numbers. It needs to be in excel and not access. There are two sheets in the workbook. "All" tracks the first name, second name, and other information. This workbooks is about 8000 rows at present and growing. "EmpCon List" (Employer / Contractor) is a database of their first name, second name and badge number and has a stable amount of rows about 450. There is a data validation between All and Emp Con so their names must match perfectly
The macro is designed to match the first and second name in "All" against the first name in "EmpCon List", and then match it to a badge number which is to appear in "All".
The macro appears to be logical, a double For loop. However, the program does not respond correctly and "whites out" after a few seconds of running. Is there a way to help VBA process this?
Sub BadgeNumberLookUp()
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("All").Select ' Job Number page
JobRows = Application.CountA(Range("A:A")) + 10 ' This number is 8000 and growing
Sheets("EmpCon List").Select 'Employee / Contractors sheet
EmployeeCount = Application.CountA(Range("M:M")) + 10 ' This number is about 450 and stable
For i = 1 To JobRows
Sheets("All").Select
jobPrenom = Cells(i, 1).Value
jobSurname = Cells(i, 2).Value
For j = 1 To EmployeeCount
Sheets("EmpCon List").Select
prenom = Cells(j, 13).Value
surname = Cells(j, 14).Value
indexNo = Cells(j, 12).Value
badgeNumber = Cells(j, 15).Value
' Use UCase as sometimes the names are not always in lower/uppercase
If UCase(prenom) = UCase(jobPrenom) And UCase(surname) = UCase(jobSurname) Then
Sheets("All").Select
Cells(i, 16).Value = badgeNumber
Exit For
End If
Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Not the solution (AFAIK), but I just wanted to show you how to cut down your code (and any potential pitfalls with .Select). This should do the same. Note how I created two worksheet variables, and then qualified the ranges with the sheet the info is coming from.
Sub BadgeNumberLookUp_No_Select()
Dim i As Integer, j As Integer
Dim empConWS As Worksheet, allWS As Worksheet
Set empConWS = Sheets("EmpCon List")
Set allWS = Sheets("All")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Sheets("All").Select ' Job Number page
JobRows = Application.CountA(allWS.Range("A:A")) + 10 ' This number is 8000 and growing
'Sheets("EmpCon List").Select 'Employee / Contractors sheet
EmployeeCount = Application.CountA(empConWS.Range("M:M")) + 10 ' This number is about 450 and stable
For i = 1 To JobRows
'Sheets("All").Select
With allWS
jobPrenom = .Cells(i, 1).Value
jobSurname = .Cells(i, 2).Value
End with
For j = 1 To EmployeeCount
'Sheets("EmpCon List").Select
With empConWS
prenom = .Cells(j, 13).Value
surname = .Cells(j, 14).Value
indexNo = .Cells(j, 12).Value
badgeNumber = .Cells(j, 15).Value
End With
' Use UCase as sometimes the names are not always in lower/uppercase
If UCase(prenom) = UCase(jobPrenom) And UCase(surname) = UCase(jobSurname) Then
'Sheets("All").Select
allWS.Cells(i, 16).Value = badgeNumber
Exit For
End If
Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Run this and see if the same errors occur for you.
Related
I know this has been asked many times but I keep reading and cant get it right. I have included all the necessary End If and the Do is there for my Loop.
My Code
Sub update_names()
Dim EMAIL, NewName As String
Dim i, total As Integer
Dim Search As Range
total = 0
i = 2024
Do While i < 2048
Sheets("Edit Multiple Subscribers").Select
EMAIL = Cells(i, 2).Value
NewName = Cells(i, 1).Value
Sheets("MASTER").Select
With Worksheets("MASTER").Cells
Set Search = .Find(EMAIL, LookIn:=xlValues, After:=ActiveCell)
If Search Is Nothing Then
Sheets("Edit Multiple Subscribers").Select
Cells(i, 2).Interior.Color = RGB(250, 0, 250)
GoTo Add1
Else:
Search.Select
ActiveCell.Offset(0, -1).Select
If ActiveCell.Value = NewName Then
GoTo Add1
Else:
NewName = ActiveCell.Value
End If
End If
Sheets("Edit Multiple Subscribers").Select
ActiveSheet.Cells(i, 2).Select
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = NewName
total = total + 1
Add1: i = i + 1
Loop
MsgBox "Number Of edits: " & total
End Sub
You're missing an End With statement, which is equivalent to forgetting an End If-statement as you pointed out yourself.
Side note: I would discourage using GoTo-statements as they make code harder to read and maintain.
The reason for you error already got an answer in #Stanislas answer above.
However, there are a lot other thing you should avoid in your VBA code, like how to avoid using Select, and ActiveCell, instead use fully qualified objects.
Example, in your code you have :
Sheets("Edit Multiple Subscribers").Select
ActiveSheet.Cells(i, 2).Select
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = NewName
This could be replaced with:
Sheets("Edit Multiple Subscribers").Cells(i, 2).Offset(0, -1).Value = NewName
which is not only shorter, but the code will run a lot faster.
Another issue: you have Dim i, total As Integer which means total As Integer but i is actually Variant. You need to define each one explicitly : Dim i As Long, total As Long , I am using Long since it's safer than Integer (can take higher values), and with Windows based x64 systems, they take just as much as memory.
Implementing a few other small modifications, your code could look a little like this:
Option Explicit ' <--- get used to add this at the top of your code
Sub update_names()
Dim EMAIL As String, NewName As String
Dim i As Long, total As Long
Dim Search As Range
total = 0
i = 2024
Do While i < 2048
With Sheets("Edit Multiple Subscribers")
EMAIL = .Cells(i, 2).Value
NewName = .Cells(i, 1).Value
End With
With Worksheets("MASTER")
Set Search = .Cells.Find(EMAIL, LookIn:=xlValues)
If Search Is Nothing Then
Sheets("Edit Multiple Subscribers").Cells(i, 2).Interior.Color = RGB(250, 0, 250)
Else
If Search.Offset(0, -1).Value <> NewName Then
NewName = Search.Value
Sheets("Edit Multiple Subscribers").Cells(i, 2).Offset(0, -1).Value = NewName
total = total + 1
End If
End If
End With
i = i + 1
Loop
MsgBox "Number Of edits: " & total
End Sub
I'm trying to get info from multiple comboboxes and place them in a
another sheet. I was able to do it if I change the columns to 1,2,3,4... etc..
but I am having difficulty trying to start the data in 8,9,10... then repeat on the next row.
I think I must be missing something small.. hopefully.
The code below fills the row once, but when I ran again it writes over it.
but If I change the columns to 1,2,3,4.... it writes the next row ... again the next row.
I'm not sure how to make it write the next row when I want the data to start population in H2.
Is there something I can add to make it write to the next row each time this runs H3, H4, H5? - fyi this needs to work for up to 3,000 rows.
Private Sub Submit_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("EvaluationTable")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' If Range("H2").Value = "" Then
' starts with H2 fills in values from combobox left to right on
With ws
.Cells(lRow, 8).Value = Me.CMB1.Value
.Cells(lRow, 9).Value = Me.CMB2.Value
.Cells(lRow, 10).Value = Me.CMB3.Value
.Cells(lRow, 11).Value = Me.CMB4.Value
.Cells(lRow, 12).Value = Me.CMB5.Value
.Cells(lRow, 13).Value = Me.TextBox1.Text
End With
'If Range("H2").Value > "" Then
' With ws
' ActiveCell.Offset(2, 0).Select
' .Cells(lRow, 8).Value = Me.CMB1.Value
' .Cells(lRow, 9).Value = Me.CMB2.Value
' .Cells(lRow, 10).Value = Me.CMB3.Value
' .Cells(lRow, 11).Value = Me.CMB4.Value
' .Cells(lRow, 12).Value = Me.CMB5.Value
' End With
Unload Me
'End If
' End If
End Sub
This an easy way to get the data from the comboboxes to a worksheet:
Option Explicit
Sub TestMe()
Dim cnt As Long
Dim startFrom As Long
startFrom = 10
For cnt = 1 To 3
Cells(startFrom + cnt, 1) = OLEObjects("ComboBox" & cnt).Object.Value
Next cnt
End Sub
Here you start from the first ComboBox and you go up to the third one.
If the comboboxes are on a form (as I guess from the usage of Me., this is a working way to do it, following the same logic from above:
Private Sub Submit_Click()
Dim cnt As Long
Dim startFrom As Long
startFrom = 10
For cnt = 1 To 3
Cells(startFrom + cnt, 1) = Me.Controls("ComboBox" & cnt).Value
Next cnt
End Sub
I have an Excel Table, with some columns. But at the moment a have a problem with column Duration.
When I scrolled down the table, i have unexpectedly noticed, that many IDs have empty lines, and only one line of this ID has an actual value.
Is it possible to fill up other empthy lines with this only one existing value using VBA? That means, that all empty values for ID6979960 should be filled up with a value 42:15:56, and so on.
Without that, my other calculations in my table, don't work properly.
I don't know exactly how copying of values works in VBA.
Public Sub FillEmpty()
Dim finded As Range
Dim Sheet As Worksheet
Set Sheet = ActiveSheet 'or any other sheet -> .Sheets("")
With Sheet
lastrow = .Cells(1, 1).End(xlDown).Row
For i = 1 To lastrow
If StrComp(.Cells(i, 2).Value, "") = 0 Then
Set finded = .Columns(2).Find("*", after:=.Cells(i, 2), LookIn:=xlValues)
ID = .Cells(finded.Row, 1).Value
Filler = .Cells(finded.Row, 2).Text
Else
ID = .Cells(i, 1).Value
Filler = .Cells(i, 2).Text
End If
Index = i
While ID = .Cells(Index, 1).Value
.Cells(Index, 2).Value = Filler
Index = Index + 1
Wend
Next i
End With
End Sub
Made it real quick so not the most optimal solution. I tested it with your example and it works. Not sure with many more rows. Check it and let me know if it works for you.
Sub fillerv2()
rowscnt = 1000
tmi = 1
tm = ""
For i = 1 To rowscnt
If tm <> Cells(i, 1).Value Then
For o = tmi To i - 1
If IsEmpty(Cells(o, 2).Value) = False Then
Pattern = Cells(o, 2).Value
Exit For
End If
Next o
For o = tmi To i - 1
Cells(o, 2).Value = Pattern
Next o
tm = Cells(i, 1).Value
tmi = i
End If
Next i
First, thanks for reading and any help offered.
I'm basically clueless here. I've spent the last several days trying to figure out how to code what I'd like done, and I'll try to explain it clearly.
My workbook has multiple sheets, but only two of them are of interest regarding this: Schedule & Shift.
On Schedule, there are 17 columns and 40-100 rows containing the employees name (column A) in one column, their initials (B), their employee number (C), their shift (D) and shift hours (E - which is returned via vlookup to another sheet).
Basically, I want a button that will copy the data from each of those 5 columns to the Shift sheet starting at "A3" and continue to copy down the rows in Schedule until it reaches a blank field for their name (which is column A).
So far, I've managed to copy the first row and the second row with the following code:
Private Sub CommandButton1_Click()
Dim i As Integer, IntName As String, IntInit As String, IntID As Integer, Shift As String, Hours As Integer
Worksheets("Schedule").Select
i = 1
IntName = Range("a4")
IntInit = Range("b4")
IntID = Range("C4")
Shift = Range("D4")
Hours = Range("E4")
Do While i < 5
Worksheets("Shift").Select
Worksheets("Shift").Range("a2").Select
If Worksheets("Shift").Range("a2").Offset(1, 0) <> "" Then
Worksheets("Shift").Range("a2").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = IntName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = IntInit
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = IntID
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Shift
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Hours
Worksheets("Schedule").Select
IntName = Worksheets("Schedule").Range("a4").Offset(1, 0)
IntInit = Worksheets("Schedule").Range("b4").Offset(1, 0)
IntID = Worksheets("Schedule").Range("c4").Offset(1, 0)
Shift = Worksheets("Schedule").Range("d4").Offset(1, 0)
Hours = Worksheets("Schedule").Range("e4").Offset(1, 0)
i = i + 1
Loop
End Sub
Obviously, this is clunky, and it doesn't actually do what I want beyond the 2nd time through the loop.
Any suggestions or pointers to help me move in the right direction?
Thanks again.
You're on the right path, you just need to nest our loop in another loop. Also, heed #BruceWayne's advice.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim intCounter As Integer
Dim IntName As String
Dim IntInit As String
Dim IntID As Integer
Dim Shift As String
Dim Hours As Integer
'Adjust intCounter if you want to start on a row other than 1
intCounter = 1
Do
With Worksheets("Schedule")
IntName = .Cells(intCounter, 1).Value
IntInit = .Cells(intCounter, 2).Value
IntID = .Cells(intCounter, 3).Value
Shift = .Cells(intCounter, 4).Value
Hours = .Cells(intCounter, 5).Value
End With
If IntName = "" Then Exit Do
i = 1
Do While i < 5
'No need to use offset when you can just reference the cell directly.
'Also, not sure why you select this column anyhow.
'These lines can probably be deleted?
'If Worksheets("Shift").Range("a3").Value <> "" Then
' Worksheets("Shift").Range("a2").End(xlDown).Select
'End If
'Avoid using things like Select, ActiveCell, and ActiveSheet.
'What if someone clicks on something while your code is running?? Oops!
With Worksheets("Shift")
.Cells(i + 1, 2).Value = IntName
.Cells(i + 1, 3).Value = IntInit
.Cells(i + 1, 4).Value = IntID
.Cells(i + 1, 5).Value = Shift
.Cells(i + 1, 6).Value = Hours
End With
i = i + 1
Loop
'Increment to go to the next row of Schedule
intCounter = intCounter + 1
Loop
End Sub
brought in by Tim's concern about compact code, try this
Private Sub CommandButton1_Click()
With Worksheets("Schedule").Range("A4:E4").CurrentRegion
.Offset(1).Resize(.Rows.Count - 1).Copy Destination:=Worksheets("Shift").Range("A3")
End With
End Sub
So I have 4 sheets that are called "old", "current", "input", and "buttons". The process is to: press a button on the "buttons" sheet to clear the "current" sheet and "input" sheet, paste data onto the "input" sheet and press a macro button on the "buttons" sheet to populate the "current" sheet. Most of the macro will be formatting the "current" sheet and using index match for data from the "old" sheet. What I'm trying to do is add a step in the beginning to clear the "old" sheet and then copy and paste the data from the "current" sheet onto the "old" sheet. The reason is that I will be using this weekly and every time I run the macro, I want the "current" sheet, that was created last time I ran the macro, to move to the "old" sheet. This is currently the code that I have...
Sub Load16()
Application.ScreenUpdating = False
'Define Workbooks
Dim loopCount As Integer
Dim loopEnd As Integer
Dim writeCol As Integer
Dim matchRow As Integer
Dim writeRow As Integer
Dim writeEnd As Integer
loopEnd = WorksheetFunction.CountA(Worksheets("Input").Range("A:A"))
writeEnd = WorksheetFunction.CountIf(Worksheets("Input").Range("L:L"), "-1")
loopCount = 1
writeRow = 1
Worksheets("Buttons").Range("F17:I17").Copy
Worksheets("Current").Range("J2:M" & writeEnd).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Do While loopCount <= loopEnd
If Worksheets("Input").Cells(loopCount, 12).Value <> "" And
Worksheets("Input").Cells(loopCount, 12).Value <> 0 Then
Worksheets("Current").Cells(writeRow, 1).Value = Worksheets("Input").Cells(loopCount, 26).Value
writeCol = 2
Do While writeCol <= 9
Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 1)
writeCol = writeCol + 1
Loop
writeCol = 14
Do While writeCol <= 30
Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 5)
writeCol = writeCol + 1
Loop
Worksheets("Current").Cells(writeRow, 31).Value = Worksheets("Input").Cells(loopCount, 27)
writeRow = writeRow + 1
Else
End If
loopCount = loopCount + 1
Loop
Worksheets("Current").Range("J1").Value = "Counsel"
Worksheets("Current").Range("K1").Value = "Background"
Worksheets("Current").Range("L1").Value = "Comments"
Worksheets("Current").Range("M1").Value = "BM Action"
Lookup Data for K - M and a few other things
loopCount = 2
Do While loopCount <= loopEnd
matchRow = 0
On Error Resume Next
matchRow = WorksheetFunction.Match(Worksheets("Current").Cells(loopCount, 1).Value, _
Worksheets("Old").Range("A:A"), 0)
If matchRow = 0 Then
Else
Worksheets("Current").Cells(loopCount, 11).Value = Worksheets("Old").Cells(matchRow, 11).Value
Worksheets("Current").Cells(loopCount, 12).Value = Worksheets("Old").Cells(matchRow, 12).Value
Worksheets("Current").Cells(loopCount, 13).Value = Worksheets("Old").Cells(matchRow, 13).Value
End If
Worksheets("Current").Cells(loopCount, 10).Value =
Worksheets("Current").Cells(loopCount, 18).Value
loopCount = loopCount + 1
Loop
Sheets("Current").Range("A2:AE" & loopEnd).Sort Key1:=Sheets("Current").Range("H2"), _
Order1:=xlAscending, Header:=xlNo
Worksheets("Current").Columns("A:BZ").AutoFit
Application.ScreenUpdating = True
Worksheets("Buttons").Select
MsgBox loopEnd - 1 & " Rows processed. " & writeEnd & " Rows remain."
End Sub
Thanks guys.
A small function like this should do the trick.
Sub copy_current_data()
'Select Old Sheet
Sheets("Old").Select
'Clear all cells from Old Sheet
Sheets("Old").Cells.ClearContents
'Copy Cells from Current Sheet
Sheets("Current").Cells.Copy
'Select "A1" in old sheet
Sheets("Old").Range("A1").Select
'Paste Data
ActiveSheet.Paste
End Sub