In VBA code,how to add values to a listbox using for each cell approach with defining a range End(XlDown)? - excel

I have created a macro file with Forms and Word to Excel.
In this coding fewthings are not working as per my expectation.
Get unique Employee Name from Excel data base.
I want to add unique employee names from excel database and get is saved in a sheet. After that those values to be added to list box. Here i cannot define a range like "A1:A10".. I want to choose the data from A1 to end data.
If for each cell approach will not work, please help in do while approach
I need help in defining the range and code given below
ListEmployeeName.Clear
For Each cell In Worksheets("SunEmployeeDetails").Range("A1").End(xlDown)
ListEmployeeName.AddItem (cell.Value)
Next
ListEmployeeName.Value = Worksheets("SunEmployeeDetails").Range("A1")
End Sub

Find Last Row and then define your range Range("A1:A" & LastRow)
You can also find the last row and loop through the range using a For loop. Also to get unique Employee Name, you can use On Error Resume Next with a Collection as shown below. I have commented the code below so you should not have a problem understanding it. But if you do then simply ask.
Is this what you are trying? (Untested).
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection
Dim itm As Variant
Set ws = Worksheets("SunEmployeeDetails")
With ws
'~~> Find Last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range and add it to the unique
'~~> collection using "On Error Resume Next"
For i = 1 To lRow
On Error Resume Next
col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
ListEmployeeName.Clear
'~~> add the itme from collection to the listbox
For Each itm In col
ListEmployeeName.AddItem itm
Next itm
End Sub

Here is my take on it, techniques taken from here:
Methode 1: Using a dictionary
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:A" & lr).Value
End With
'Loop through memory and fill dictionary
For x = LBound(arr) To UBound(arr)
dict(arr(x, 1)) = 1
Next x
'Add array to Listbox
Me.ListEmployeeName.List = dict.Keys
Methode 2: Using Evaluation
Dim lr As Long
Dim arr As Variant
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array of unique values
arr = Filter(.Evaluate("TRANSPOSE(If(Row(A1:A" & lr & ")<>MATCH(A1:A" & lr & ",A1:A" & lr & ",0),""|"",A1:A" & lr & "))"), "|", False)
'Add array to Listbox
Me.ListEmployeeName.List = arr
End With

Related

If value that is in a column on sheet A but doesn't exist in a column on sheet B add that value to sheet B

I am trying to write a script that will look in a column A on sheet1 and see if it is missing any values from column J on sheet2, and if it is missing have the value added to the bottom of the column on sheet1. I found some example code (see below), however, when I modify it to work across the two sheets I get an error.
Sub Macro1()
Dim rngA As Range, rngB As Range, MySel As Range, LastRow As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngA = .Range("A1:A" & LastRow)
Set rngB = .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
End With
For Each cell In rngB
If IsError(Application.Match(cell.Value, rngA, 0)) Then
If MySel Is Nothing Then
Set MySel = cell
Else
Set MySel = Union(MySel, cell)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:=ws.Range("A" & LastRow + 1)
End Sub
Any help to modify this to function across sheets would be greatly appreciated. Thanks!
You may try the following code modification, you are getting the error due to the variable cell was not declared and ws.Range("B" & .Rows.Count).End(xlUp) is not a valid range, and you should set Range B by referring to another worksheet if you want to do so:
Sub Macro1()
Dim rngA As Range, rngB As Range, MySel As Range
Dim LastRowA As Long, LastRowB As Long
Dim ws As Worksheet
Dim cell As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
LastRowB = .Range("B" & .Rows.Count).End(xlUp).Row
Set rngA = .Range("A1:A" & LastRowA)
Set rngB = .Range("B1:B" & LastRowB)
End With
For Each cell In rngB.Cells
If IsError(Application.Match(cell.Value, rngA, 0)) Then
If MySel Is Nothing Then
Set MySel = cell
Else
Set MySel = Union(MySel, cell)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:=ws.Range("A" & LastRowA + 1)
End Sub
Before:
After:
Array approach using one-liner for Match()
Instead of looping through a data range you can execute an array Match()
to compare data values with reference values by a one-liner:
data = Application.Match(ref, data, 0)
Methodical hint
Findings return the position within the reference array, whereas all non-findings (i.e. new and therefore unique values) can be identified easily by a corresponding error entry. This is used to re-write the data array exclusively by the wanted uniques. The resulting data are eventually added in the needed size to the existing data.
Note that commonly the Match() function loops asking for single search values (1st parameter) within a reference array (2nd parameter),
e.g. via Application.Match(SingleSearchValue, reference, 0).
Side note: looping through a range by means of VBA can be time consuming for greater data set, so generally I prefer an array approach.
As OP seems to refer to two sheets with different columns A and J (instead of B),
I demonstrate a solution following this requirement.
Option Explicit
Sub AppendNewItems()
'1) get data & reference arrays via function GetDatafield()
Dim data: data = GetDatafield(Sheet1, "A") ' current data
Dim ref: ref = GetDatafield(Sheet2, "J") ' reference values
Dim NewRow As Long
NewRow = UBound(data) + 1 ' get starting row for new entries
'2) look up all of the data in the reference array and write found positions to data (one-liner)
data = Application.Match(ref, data, 0)
'Edit2: check for no or only 1 reference item ' << 2021-07-23/see comment
On Error Resume Next
Debug.Print data(1, 1)
If Err.Number <> 0 Then
Err.Clear
ReDim tmp(1 To 1, 1 To 1)
tmp(1, 1) = data(1)
data = tmp
End If
'3) take only new (=unique) elements
Dim i As Long, ii As Long
For i = 1 To UBound(data) ' loop through matches
If IsError(data(i, 1)) Then ' identify new (=not found) elements by error
ii = ii + 1 ' increment uniques counter
data(ii, 1) = ref(i, 1) ' replace error element with current reference value
End If
Next
'4) add new data to column A (not more than ii elements)
If ii Then
Sheet1.Range("A" & NewRow).Resize(ii, 1) = data
End If
End Sub
Help function GetDatafield()
Function GetDatafield(sht As Worksheet, Col As String)
Dim LastRow As Long
LastRow = sht.Range(Col & sht.Rows.Count).End(xlUp).Row
'return 1-based 2-dim datafield array
GetDatafield = sht.Range(Col & "1:" & Col & LastRow).Value2
'force single value into array ' << Edit 2021-07-22/see comment
If Not IsArray(GetDatafield) Then ' or: If LastRow = 1 Then
ReDim tmp(1 To 1, 1 To 1)
tmp(1, 1) = sht.Range(Col & "1").Value2
GetDatafield = tmp ' pass 2-dim array
End If
End Function

Deleting Duplicates while ignoring blank cells in VBA

I have some code in VBA that is attempting to delete duplicate transaction IDs. However, i'd like to ammend the code to only delete duplicates that have a transaction ID - so, if there is no transaction ID, i'd like that row to be left alone. Here is my code below:
With MySheet
newLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
newLastCol = .Cells(5 & .Columns.Count).End(xlToLeft).Column
Set Newrange = .Range(.Cells(5, 1), .Cells(newLastRow, newLastCol))
Newrange.RemoveDuplicates Columns:=32, Header:= _
xlYes
End With
I was also wondering - in the remove.duplicates command - is there a way where I can have the column I want looked at to be named rather than have it be 32 in case I add or remove columns at a later date?
Here is an image of the data: I'd like the ExchTransID column that have those 3 blank spaces to be left alone.
Modify and try the below:
Option Explicit
Sub test()
Dim Lastrow As Long, Times As Long, i As Long
Dim rng As Range
Dim str As String
'Indicate the sheet your want to work with
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row with IDs
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the range with all IDS
Set rng = .Range("A1:A" & Lastrow)
'Loop column from buttom to top
For i = Lastrow To 1 Step -1
str = .Range("A" & i).Value
If str <> "" Then
Times = Application.WorksheetFunction.CountIf(rng, str)
If Times > 1 Then
.Rows(i).EntireRow.Delete
End If
End If
Next i
End With
End Sub

Transferring Cell Values Between Worksheets | Str Looper

Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

How to append data to a column in a loop

My script takes data from multiple sheets and creates a new spreadsheet. The problem I am running into is how to append to the end of a column. I tried this:
LastRow = Sheets("Test").Cells(Rows.Count, "A").End(xlUp).Row
Where LastRow is defined as a long but I ran into an error when my loop continued going around. Here is what I have so far:
Sub autoFill()
Dim wb As Workbook, ws As Worksheet
Dim LastRow As Long
Dim Unit As String
Dim ddg As Variant, i As Variant
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Mapping")
ddg = ws.Range("F4:F21").Value
For Each i In ddg
Unit = "Unit #" & i
LastRow = Sheets("Test").Cells(Rows.Count, "A").End(xlUp).Row
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A1" & LastRow)
Sheets(Unit).Range("B2:B100").Copy Destination:=Sheets("Test").Range("B1" & LastRow)
Next i
End Sub
Just pick a range WAY above whatever the last row might be in whatever column will be populated (A in this case) when using xlUp. Add 1 to get to the next row:
LastRow = Sheets("Test").Range("A50000").End(xlUp).Row + 1
LAstRow now has a number that is equal to the first unused row in Column A of sheet Test.
Now concatenate that number to "A" to make a range like "A50". Right now you are doing:
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A1" & LastRow)
Which is concatenating the number to "A1" so you get "A150" which is nonsense... Instead:
Sheets(Unit).Range("A2:A100").Copy Destination:=Sheets("Test").Range("A" & LastRow)

Vba comparing then copying two different Sheets

I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.

Resources