Worksheet: MASTER DATA
Column A = Engine.
Column B = Part Number.
Column C = Status.
Column D = Name.
Column E = Quantity.
Column F = Date.
Column G = Priority.
Column H = Buyer.
Situation:
I enter all the data from column A to H manually. I made a userform to enter data from column J to M.
In my Userform:
If I select the buyer in the combobox, I want the listbox to populate with all the partnumbers in sheet "MASTER DATA" that correspond to that specific buyer. I was thinking about using a vlookup to the buyer value, and then maybe offsetting -6 to pick up the partnumber value?
Any help is appreciated.
My Code so far:
Private Sub UserForm_Initialize()
With cboBuyer
.AddItem "DANIEL"
End With
End Sub
Private Sub cboBuyer_Change()
Me.lbPartNumber.Clear
Select Case Me.cboBuyer.Value
Case "DANIEL"
With Me.lbPartNumber
.AddItem "(VLOOKUP VALUES TO THE BUYER NAME (DANIEL)
End With
End Select
End Sub
solution
Private Sub cboBuyer_Change()
Dim i
Me.lbPartNumber.Clear
Dim lastrow As Long
lastrow = Sheets("MASTER DATA").Cells(Rows.count, "B").End(xlUp).Row
Select Case Me.cboBuyer.Value
Case "DANIEL"
With Me.lbPartNumber
For i = 1 To lastrow ' Rowcount
Sheets("MASTER DATA").Activate
If Cells(i, 8) = "DANIEL" Then
.AddItem Cells(i, 2)
End If
Next i
End With
End Select
Related
Suppose I have the following table with three columns. I want to search for an exact match or next previous date from Column3, conditional to Column1 being a given value.
This can be easily done with XLOOKUP. However, I need to do so in VBA because I'll show the date found in a userform Textbox to the user. From what I have searched so far, Application.Worksheetfunction.Xlookup won't work with an & for multiple criteria, so the solution for this would involve manipulating arrays.
I created a variant from that table by writing:
Dim TBL As ListObject
Set TBL = Sheets("sheet1").ListObjects("Table1")
Dim DirArray As Variant
DirArray = TBL.DataBodyRange
Any advice on how to get that approximate match using arrays?
Using an array of values will be faster than referencing a cell for each check - esp. if your table is much larger.
You can use this function - it will return 0 in case no valid date is found.
As I am using sortBy you will need Excel 365 for this to work.
By using SortBy it is safe to exit the for-loop in case we have found a matching date.
Public Function nearestDate(lo As ListObject, valueColumn1 As String, valueColumn3 As Date) As Date
Dim arrValues As Variant
arrValues = Application.WorksheetFunction.SortBy(lo.DataBodyRange, lo.ListColumns(1).DataBodyRange, 1, lo.ListColumns(3).DataBodyRange, 1)
Dim i As Long
For i = 1 To UBound(arrValues, 1)
If arrValues(i, 1) = valueColumn1 Then
If arrValues(i, 3) = valueColumn3 Then
'we found what we are looking for
nearestDate = arrValues(i, 3)
ElseIf arrValues(i, 3) < valueColumn3 Then
'we have to check next row - if there is one
If i < UBound(arrValues, 1) Then
If arrValues(i + 1, 1) = valueColumn1 And arrValues(i + 1, 3) > valueColumn3 Then
'same column1 but column3 greater than valueColumn3
nearestDate = arrValues(i, 3)
ElseIf arrValues(i + 1, 1) <> valueColumn1 Then
'new column1 value --> therefore we take current date
nearestDate = arrValues(i, 3)
End If
Else
'last value --> ok
nearestDate = arrValues(i, 3)
End If
End If
End If
If nearestDate > 0 Then Exit For
Next
End Function
You can call this function like this:
Public Sub test()
Dim ws As Worksheet: Set ws = Thisworkbook.Worksheets("sheet1")
Dim lo As ListObject: Set lo = ws.ListObjects("Table1")
Dim valueColumn1 As String: valueColumn1 = ws.Range("F1")
Dim valueColumn3 As Date: valueColumn3 = ws.Range("F2")
Debug.Print nearestDate(lo, valueColumn1, valueColumn3)
End Sub
There may well be a neater answer, but here is a simple brute-force function that just scans down every row in the given data looking for the closest match to the given criteria. The function returns the date of the closest match, but maybe it would be more useful to you if it returned, say, the row number of the row that is the closest match. Put this function in a new code module so that it can be called as a function from a cell, for example =findEntryByCol1andCol3(Table1,F1,F2)
Option Explicit
Public Function findEntryByCol1andCol3(dataToSearch As Range, findCol1, findCol3) As Variant
'// variable to hold the row with the closest match to criteria
Dim matchRow As Range
Set matchRow = Nothing
'// variable to hold the row being checked
Dim checkRow As Range
Dim ix As Long
For ix = 1 To dataToSearch.Rows.Count
'// get the next row to be checked
Set checkRow = dataToSearch.Rows(ix)
'// does column 1 in this row match the search criterion for column 1?
If checkRow.Cells(1, 1).Value = findCol1 Then
'// now see if the date in the row is less than the search date
If findCol3 >= checkRow.Cells(1, 3).Value Then
'// If there has been no match then use this checked row as the first found match
If matchRow Is Nothing Then
Set matchRow = checkRow
'// If there has been a previous match check
'// if the new date is later that the previously found date
ElseIf matchRow.Cells(1, 3).Value < checkRow.Cells(1, 3).Value Then
Set matchRow = checkRow
End If
End If
Else
End If
Next ix
'// Now return the result of the search
If matchRow Is Nothing Then
findEntryByCol1andCol3 = "Not found"
Else
findEntryByCol1andCol3 = matchRow.Cells(1, 3)
End If
End Function
I have two data workbooks. One dataset is of refused orders and the other dataset is for current orders. I want to find if i can match orders so that i can utilize the orders that I have in refused file. This way i wont have to make the current order and can simultaneously reduce my stack of orders that have been refused by customers. Here is my Data sheets for refused and current/printed orders.
Current/Printed Orders
Here is datasheet for the refused orders.
Refused Orders
I need to match orders on three things. First the design name needs to match, the product name needs to match and the size needs to match in order to get an "order match".
How can I use excel vba to find matches and create a new excel worksheet in the current order workbook that can show the orders that match between both data sets. The final data output would be order number against order number from both the files.
I am just beginning to learn vba but this is a complex problem that i can not solve. Please help. I wrote a code but it does not run. It says object not defined. Code that i wrote is :
Sub Comparetwosheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1row As Long, ws2row As Long, w1scol As Integer, ws2col As Integer
Dim report As Worksheet
Dim row As Long, col As Integer
Dim R1 As Range
Set R1 = Union(col(5), col(7), col(10))
Set report = Worksheet.Add
'Set numrows = number of rows of data
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' Select cell a1.
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
x = 2
Do While x < NonBlank
x = x + 1
Do While (ws1.R1 = ws2.R1)
If ws1.rw2 = ws2.rw2 Then
report.Cells(1, 1).Value = "Match"
Else: x = x + 1
Loop
Loop
'Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
End Sub
This should be able to do it for you. You are able to set the following variables in the CompareWorksheet subroutine to what you need then to be (dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2). I am using a random dataset from the world bank.
Sub CompareWorksheet()
Dim dataSet1, dataSet2 As Variant
Dim workbook1, workbook2 As String
Dim worksheet1, worksheet2 As String
Dim rowStart1, rowStart2 As Integer
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook1 = "dashboard-data-latest1.xlsx"
worksheet1 = "2. Harmonized Indicators"
dataSet1 = SheetToDataSet(workbook1, worksheet1)
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook2 = "dashboard-data-latest.xlsx"
worksheet2 = "2. Harmonized Indicators"
dataSet2 = SheetToDataSet(workbook2, worksheet2)
'Set this do what columns you are interested in comparing
colPos1 = Array(1, 2, 3)
colPos2 = Array(1, 2, 3)
'Set for where you want to start 1 would be row 1/now Header.
rowStart1 = 2
rowStart2 = 2
'Compares the dataSets
Compare2Sheets dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2
End Sub
Function Compare2Sheets(dataSet1 As Variant, dataSet2 As Variant, colPos1 As Variant, colPos2 As Variant, rowStart1 As Variant, rowStart2 As Variant)
If UBound(colPos1) = UBound(colPos2) Then
For I = rowStart1 To UBound(dataSet1, 1)
For j = rowStart2 To UBound(dataSet2, 1)
matchFlag = 0
For k = 0 To UBound(colPos1)
If dataSet1(I, colPos1(k)) = dataSet2(j, colPos2(k)) Then
matchFlag = matchFlag + 1
End If
Next k
If matchFlag = (UBound(colPos1) + 1) Then
Debug.Print ("Match found in Workbook 1 at row " & I & " and Workbook 2 at row " & j)
End If
Next j
Next I
End If
End Function
Function SheetToDataSet(workbookName As Variant, worksheetName As Variant) As Variant
'SET PAGE CHARACTERISTICS
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'DECLARE VARIABLE
Dim x_matrix As Range
Dim x_copyrange As String
Dim length, lastColumn As Integer
'DEFINE VARIABLE
Workbooks(workbookName).Worksheets(worksheetName).Activate
length = 0
lastColumn = 0
For I = 1 To 10
If length < Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row Then
length = Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row
End If
If lastColumn < Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column Then
lastColumn = Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column + 10
End If
Next I
'Let x_copyrange = .Range(.Cells(1, 1), .Cells(length, lastColumn))
'Return
SheetToDataSet = Workbooks(workbookName).Worksheets(worksheetName).Range(Cells(1, 1), Cells(length, lastColumn))
End Function
I want the vba event array & dictionary code because there are 50 thousand row records. the code I made sometimes runs and sometimes it doesn't run maybe something is wrong in my code.If I use the formula it will run very slowly.
I tried to copy 2 lines in the code column but the results of my vba code do not match and can only run if I do only copy 1 line in the code column and I also use it as a form in the receive item sheet, can it work if the formula becomes vba in the MASTER RI (ROLL) sheet?
for information I use excel 2010
Formula information in sheet ("MASTER RI (ROLL)")
Column A :=IF(I2='RECEIVE ITEM'!$F$7,N(A1)+1,N(A1))
Column B :=IF(MAX($C$2:$C$57675)<ROW(1:1),"",VLOOKUP(ROW(1:1),$C$2:$I$57675,7,0))
Column C : =IF(COUNTIF(I$1:I2,I2)=1,MAX(C$1:C1)+1,"")
Column D : =IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],3,0))
Column E : =IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],4,0))
Column F :=IF([#[SUPPLIER NAME]]="","",VLOOKUP([#[SUPPLIER NAME]],Table2[[#All],[SUPPLIER NAME]:[POSTAL CODE]],6,0))
Column G :=IF([#[QTY IN ACTUAL]]=""," ",[#[QTY IN ACTUAL]])
Column Q : =[#[QTY IN ACTUAL]]*[#rate]
Column T : =[#[QTY IN ACTUAL]]*[#[NEW PRICE]]
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
If Intersect(Target, Range("L:L")) Is Nothing Then Exit Sub
Dim fnd As Range
Set fnd = Sheets("MASTER").Range("B:B").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing Then
Target.Offset(, 2).Resize(, 1).Value = Array(fnd.Offset(, 3))
Target.Offset(, 4).Resize(, 1).Value = Array(fnd.Offset(, 6))
Target.Offset(, 6).Resize(, 1).Value = Array(fnd.Offset(, 8))
Target.Offset(, 7).Resize(, 1).Value = Array(fnd.Offset(, 4))
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
MASTER RI (ROLL)
DB SUPPLIER
RECEIVE ITEM
MASTER
I'm making some sort of football database where I would input data using a userform and where I want to retrieve data from my excel database.
I have a worksheet named: "wedstrijden" This worksheet contain the columns: Date, HomeTeam, AwayTeam, HomeScore,AwayScore, HomeOdds and AwayOdds
My other worksheet is named: "ingevenuitslagen" This worksheet contains my userform called UitslagenIngeven
Using the code below I'm able to input my data from the userform to my "wedstrijden" worksheet
Private Sub putAway_Click()
Dim ingevenuitslagen As Worksheet
Set ingevenuitslagen = ThisWorkbook.Sheets("wedstrijden")
NextRow = ingevenuitslagen.Cells(Rows.Count, 1).End(xlUp).Row + 1
ingevenuitslagen.Cells(NextRow, 1) = CDate(date_txt.Text)
ingevenuitslagen.Cells(NextRow, 2) = UitslagenIngeven.cboHomeTeam
ingevenuitslagen.Cells(NextRow, 3) = UitslagenIngeven.cboAwayTeam
ingevenuitslagen.Cells(NextRow, 4) = UitslagenIngeven.cboHScore
ingevenuitslagen.Cells(NextRow, 5) = UitslagenIngeven.cboAScore
ingevenuitslagen.Cells(NextRow, 6) = Val(UitslagenIngeven.hodds_txt.Text)
ingevenuitslagen.Cells(NextRow, 7) = Val(UitslagenIngeven.aodds_txt.Text)
End Sub
But this is only to put away 1 row. I would like to make the possibility to put away 10 or 15 rows at once. So I would make a userform with the possibility to put away 20 rows BUT it should be able to put away only those rows that are filled in.
Is this possible? And how should I adjust my userform? Can I just copy the text and combobox areas ?
How to work with a Data Array
You'll need to create a new button, you'll have :
one for adding the data set to the data array (here CommandButton1) and
one to add the data array to the data base (here CommandButton2).
I also prefer to work with a Named Range for the Data Base, here it is called Db_Val but you can rename this to fit your needs! ;)
Code to place in the UserForm to fill the data array :
Public ingevenuitslagen As Worksheet
Public DataA() '----These lines should be at the top of the module
'----Code to Set the dimension of the Data array
Private Sub UserForm_Initialize()
Dim DataA(7, 0)
Set ingevenuitslagen = ThisWorkbook.Sheets("wedstrijden")
'----Rest of your code
End Sub
'----Code to add a data set to the data array
Private Sub CommandButton1_Click()
UnFilter_DB '----See below procedure
DataA(1) = CDate(date_txt.Text)
DataA(2) = UitslagenIngeven.cboHomeTeam
DataA(3) = UitslagenIngeven.cboAwayTeam
DataA(4) = UitslagenIngeven.cboHScore
DataA(5) = UitslagenIngeven.cboAScore
DataA(6) = Val(UitslagenIngeven.hodds_txt.Text)
DataA(7) = Val(UitslagenIngeven.aodds_txt.Text)
ReDim Preserve DataA(LBound(DataA, 1) To UBound(DataA, 1), LBound(DataA, 2) To UBound(DataA, 2) + 1)
End Sub
'----Code to sent the data array to the DB
Private Sub CommandButton2_Click()
ReDim Preserve DataA(LBound(DataA, 1) To UBound(DataA, 1), LBound(DataA, 2) To UBound(DataA, 2) - 1)
SetData DataA
End Sub
Procedure to print in the database the data array that you pass from the user form :
Here the data base is the Named Range Db_Val in ingevenuitslagen sheet
Public Sub SetData(ByVal Data_Array As Variant)
Dim DestRg As Range, _
A()
'----Find the last row of your DataBase
Set DestRg = ingevenuitslagen.Range("Db_Val").Cells(ingevenuitslagen.Range("Db_Val").Rows.Count, 1)
'----Print your array starting on the next row
DestRg.Offset(1, 0).Resize(UBound(Data_Array, 1), UBound(Data_Array, 2)).Value = Data_Array
End Sub
Sub to unfilter the DB you are working with :
Public Sub UnFilter_DB()
'----Use before "print" array in sheet to unfilter DB to avoid problems (always writing on the same row if it is still filtered)
Dim ActiveS As String, CurrScreenUpdate As Boolean
CurrScreenUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
ActiveS = ActiveSheet.Name
ingevenuitslagen.Activate
ingevenuitslagen.Range("A1").Activate
ingevenuitslagen.ShowAllData
DoEvents
Sheets(ActiveS).Activate
Application.ScreenUpdating = CurrScreenUpdate
End Sub
Good day all.
I have this same challenge. Mine is to be able to place a Customer's Orders. With the code I have I can only place one product per order at a time for the customer. I want to be able to place multiple products per order for one customer at the same time in a Userform and it will update multiple rows. The code below can only update one row with one product in a row for one customer:
Private Sub cmdAdd_Click()
Dim lRow As Long
Dim ws As Worksheet
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.Cells(lRow, 1).Value = Me.Data1.Value
.Cells(lRow, 2).Value = Me.Data2.Value
.Cells(lRow, 3).Value = Me.Data3.Value
.Cells(lRow, 4).Value = Me.Data4.Value
.Cells(lRow, 5).Value = Me.Data5.Value
.Cells(lRow, 6).Value = Me.Data6.Value
.Cells(lRow, 7).Value = Me.Data7.Value
.Cells(lRow, 8).Value = Me.Data8.Value
.Cells(lRow, 9).Value = Me.Data9.Value
.Cells(lRow, 10).Value = Me.Data10.Value
End With
End Sub
The above can only update One product per customer. A customer could place order for more than one product.
I'm currently using this template to log employee holiday requests
http://office.microsoft.com/en-gb/templates/employee-absence-schedule-TC103987167.aspx
I have added array formulas to give the specific number of days each month that an employee has had a Holiday / Unpaid leave / Sick / Late etc
eg
=SUM(LEN(B5:AF5)-LEN(SUBSTITUTE(B5:AF5,"H","")))/LEN("H")
and combined these totals to get a year overview but I still have to look through the sheets to get a full list of days they have requested and copy out the data.
Is there a formula I can put in so I can make a sheet for each employee that when H appears On sheet January B8-AF8 write sheet month name and the corresponding day and date in row 4.
I'm trying to achieve something like this as an automatic function?
I'm currently unable to post images but if you need me to elaborate please let me know.
If I understand correctly, you want 1 sheet per employee? As far as I know there isn't a way of adding sheets automatically without using some code (VBA or otherwise). If you had the sheets already created then I'm sure that we could come up with a formula.
Anyway, here is some VBA code you can try out...It creates a new workbook to summarize the data in. There isn't any error checking and it assumes that you're running it from the template that you provided. Just add a button that calls EmployeeSummary and it should work.
Type DayOffType
Month As String
DayOfWeek As String
Date As String
Type As String
End Type
Type EmployeeType
Name As String
DaysOff() As DayOffType
NumberOfDaysOff As Long
End Type
Private EmployeeData() As EmployeeType
Private EmployeeCount As Long
Sub EmployeeSummary()
Dim wb As Excel.Workbook
Call ReadSchedule(ThisWorkbook)
Set wb = Workbooks.Add
Call WriteSummary(wb, "H")
End Sub
Sub ReadSchedule(Book As Excel.Workbook)
Dim tbl As Excel.Range
Dim TableName As String
Dim sMonth As String, sDay As String
Dim iMonth As Integer, iDate As Integer
Dim iEmployee As Long, iRow As Long, iCol As Long
For iMonth = 1 To 12
sMonth = MonthName(iMonth)
With Book.Worksheets(sMonth)
TableName = "tbl" & sMonth
Set tbl = .ListObjects(TableName).Range
For iRow = 2 To tbl.Rows.Count - 1
iEmployee = GetEmployee(tbl.Cells(iRow, 1))
For iCol = 2 To tbl.Columns.Count - 1
If tbl.Cells(iRow, iCol) <> vbNullString Then
AddDayOff iEmployee, sMonth, tbl, iRow, iCol
End If
Next
Next
End With
Next
End Sub
Private Function GetEmployee(Name As String)
Dim i As Long
For i = 0 To EmployeeCount - 1
If EmployeeData(i).Name = Name Then Exit For
Next
If i >= EmployeeCount Then
ReDim Preserve EmployeeData(EmployeeCount)
EmployeeData(EmployeeCount).Name = Name
EmployeeCount = EmployeeCount + 1
End If
GetEmployee = i
End Function
Private Sub AddDayOff(Employee As Long, Month As String, Table As Range, Row As Long, Col As Long)
With EmployeeData(Employee)
ReDim Preserve .DaysOff(.NumberOfDaysOff)
With .DaysOff(.NumberOfDaysOff)
.Date = Table.Cells(1, Col)
.DayOfWeek = Table.Cells(0, Col)
.Month = Month
.Type = Table.Cells(Row, Col)
End With
.NumberOfDaysOff = .NumberOfDaysOff + 1
End With
End Sub
Private Sub WriteSummary(Book As Excel.Workbook, Optional AbsenceType As String = "H")
Dim ws As Excel.Worksheet
Dim cell As Excel.Range
Dim i As Long, d As Long
Set ws = Book.Worksheets(1)
For i = 0 To EmployeeCount - 1
With ws
.Name = EmployeeData(i).Name
.Range("A1") = EmployeeData(i).Name
Set cell = .Range("A2")
For d = 0 To EmployeeData(i).NumberOfDaysOff - 1
If EmployeeData(i).DaysOff(d).Type = AbsenceType Then
cell = EmployeeData(i).DaysOff(d).Month
cell.Offset(0, 1) = EmployeeData(i).DaysOff(d).DayOfWeek
cell.Offset(0, 2) = EmployeeData(i).DaysOff(d).Date
Set cell = cell.Offset(1, 0)
End If
Next
End With
Set ws = Book.Worksheets.Add(after:=Book.Worksheets(Book.Worksheets.Count))
Next
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub