I have a macro which performs a vlookup by taking the vendor name in column J and looks for the vendor number in my table array of my vlookup in column C and D. However when I run the macro, something goes visibly wrong with my vlookup. Please see the formula inside the picture attached. Apparently, the part of my table array in my vlookup does not work properly. Actually, I would like that my vlookup returns me a fixed table array (I mean with absolute reference and dollar) from point of origin C5 and as limit point the last row in column D (I mean the limit of my table array should be the last row of column D).
Please see my VBA code below, it seems that this part of my VBA code inside my vlookup is wrong
: C4" & LastRow & "
Thanks a lot for your help.
Xavi
Sub insertvlookuptogetmyvendornumber()
Dim LastRow As Integer
LastRow = Range("D" & Rows.Count).End(xlUp).Row
PenultimateLastRow = Range("J" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Range("I4").Select
ActiveCell.FormulaR1C1 = "Vendor number"
Range("I5").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],R5C3:C4" & LastRow & ",2,0)"
Selection.AutoFill Destination:=Range("I5:I" & PenultimateLastRow), Type:=xlFillDefault
End Sub
As per my comment I would maintain a historic table of names and numbers. I would initially read this into a dictionary and then loop the appropriate columns of the pivottable updating the dictionary value if the name exists. If the name doesn't exist then add the name and number to the dictionary. At the end write it all back out the historic table.
The historic table is your current table where you are trying to do VLookup. In this case, that table would only contain matched pairs which have new values added to it from pivottable, or existing values updated.
To re-iterate, your table on the right, columns I & J should only have matched pairs in it to start with. Hardcoded.
This assumes no subtotal/total rows within pivottable body, though these can be excluded, if present, with an update to the code.
Option Explicit
Public Sub UpdateReferenceTable()
Dim lastRow As Long, dict As Object, ws As Worksheet, pvt As PivotTable, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set pvt = ws.PivotTables("PivotTable1")
Set dict = CreateObject("Scripting.Dictionary")
With ws
lastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
End With
Dim initialDictData(), pivotTableUpdates()
initialDictData = ws.Range("I9:J" & lastRow).Value
For i = LBound(initialDictData, 1) To UBound(initialDictData, 1)
dict(initialDictData(i, 2)) = initialDictData(i, 1)
Next
Dim names(), vendorNumbers()
names = Application.Transpose(pvt.PivotFields("Name 1").DataRange.Value)
vendorNumbers = Application.Transpose(pvt.PivotFields("Vendor Number").DataRange.Value)
For i = LBound(names) To UBound(names)
If names(i) <> vbNullString Then
If dict.exists(names(i)) Then
dict(names(i)) = vendorNumbers(i)
Else
dict.Add names(i), vendorNumbers(i)
End If
End If
Next
ws.Range("I9").Resize(dict.Count, 1) = Application.Transpose(dict.items)
ws.Range("J9").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
End Sub
Data:
Related
the VBA code below scans two different datasets/tables in excel against possible matches in Worksheet 2 (aka SecondaryTable) and Worksheet 1 (aka MainTable). Both “Main” and “Secondary” Tables are Table Objects in Excel:
Sub looping()
Dim lRow As Long
Dim lCol As Long
Dim lRow2 As Long
Dim lCol2 As Long
Dim wordsArray() As Variant
wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value
Dim word As Variant
Dim cell As Range
Set sht = Worksheets("MainTable")
Set sht2 = Worksheets("SecondaryTable")
lRow = sht.Range("A1").CurrentRegion.Rows.Count
lCol = sht.Range("A1").CurrentRegion.Columns.Count
lRow2 = sht2.Range("A1").CurrentRegion.Rows.Count
lCol2 = sht2.Range("A1").CurrentRegion.Columns.Count
For Each cell In Worksheets("MainTable").Range("I2:I" & lRow)
For Each word In wordsArray
If InStr(cell.Value, word) > 0 Then
cell.Offset(0, -2).Value = cell.Offset(0, -2).Value & " " & word
End If
Next word
Next cell
End Sub
I wanted to ask if there is any good way (after several failed attempts and errors via VBA in the last couple of days) of doing the following:
Is there any way of offsetting the value identified into a specific Table column instead of counting columns to determine exactly where the data will be populated / should be offset to? I tried replacing cell.Offset(0, -2).Value with a Table reference to the column name such as “Results” however I kept getting errors.
Would there any specific way after the code finds a match from wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value to return a different value from an adjacent cell located in Range("B2:B" & lrow2).Value? The secondary table contains partial keywords in one column via which the loop is executed and a second adjacent column that contains the full name. I tried offsetting the variable word e.g., word.offset(0,1).Value in an effort to pull the name from Column 2 but only got errors.
Secondary Table example
Column A (keywords) Column B(full string)
Dog big dog
Cat small cat
Since you say Tables are Table Objects in Excel: utilise that fact. These are called ListObject's in VBA.
Replace the various NameOf... strings with your actual names
Sub looping()
Dim wordsArray() As Variant
Dim FullWordsArray() As Variant
Dim wb As Workbook
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim loSecondary As ListObject
Dim loMain As ListObject
Set wb = ThisWorkbook ' or specify a workbook
Set sht = wb.Worksheets("MainTable")
Set sht2 = ws.Worksheets("SecondaryTable")
Set loMain = sht.ListObjects(1) ' or by name: Set loMain = sht.ListObjects("YourTableName')
Set loSecondary = sht2.ListObjects(1)
' get two arrays, one for lookup, and the other for replacements
wordsArray = loSecondary.ListColumns("NameOfWordColumn").DataBodyRange.Value2
FullWordsArray = loSecondary.ListColumns("NameOfFullWordColumn").DataBodyRange.Value2
Dim WordIdx As Long
Dim SearchCol As Long
Dim UpdateCol As Long
Dim rw As Long
Dim lr As ListRow
SearchCol = loMain.ListColumns("NameOfColumnToSearch").Index
UpdateCol = loMain.ListColumns("NameOfColumnToUpdate").Index
For Each lr In loMain.ListRows
With lr.Range
For WordIdx = 1 To UBound(wordsArray, 1)
If InStr(.Cells(1, SearchCol).Value2, wordsArray(WordIdx, 1)) > 0 Then
With .Cells(1, UpdateCol)
.Value2 = .Value2 & " " & FullWordsArray(WordIdx, 1)
End With
End If
Next
End With
Next
End Sub
I have the below loop in VBA:
For i = 1 To Range("B" & "65536").End(xlUp).Row Step 1
Companies = Range("A" & i).Value
Next i
MsgBox Companies 'Output Company Name (One time)
So above loop iterates through rows, that all have a company name in Column "A". I want to add all these company names to an array, so I can print them all out later on (after the loop)
How can I dynamically add the Companies value to an array, and use it later on?
you don't need Loop
Just try this :
Dim DirArray As Variant
DirArray = Range("A1:A5000").Value
I think something like this is what you're looking for.
Sub tgr()
'Declare variables
Dim ws As Worksheet
Dim Companies As Variant
Dim i As Long
'Always fully qualify which workbook and worksheet you're looking at
Set ws = ActiveWorkbook.ActiveSheet
'You can assing a Variant variable to the value of a range
' and it will populate the variable as an array if there
' is more than one cell in the range
'Note that I am going off of column B as shown in your original code,
' and then using Offset(, -1) to get the values of column A
Companies = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Offset(, -1).Value
If IsArray(Companies) Then
'More than one company found, loop through them
For i = LBound(Companies, 1) To UBound(Companies, 1)
MsgBox "Company " & i & ":" & Chr(10) & _
Companies(i, 1)
Next i
Else
'Only one company found
MsgBox Companies
End If
End Sub
If you need an array, which is increased every time and still saves its contents, something like this should work:
Option Explicit
Public Sub TestMe()
Dim i As Long
Dim companies() As Variant
ReDim companies(0)
For i = 1 To 20
ReDim Preserve companies(UBound(companies) + 1)
companies(UBound(companies)) = Range("A" & i)
Next i
End Sub
If you need simply need to take the values to array, then the answer of #Leo R. is probably the easiest way to achieve it.
I have a dirty database where the names of each individual are written in different ways and I cannot group them.
I would like to create a macro to find and replace the names in the database using a two column list.
I have found the following code, but I´m having trouble understanding it, so cannot adapt it:
Dim Sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim Rng As Range
'Create variable to point to your table
Set tbl = Worksheets("How to").ListObjects("Table2")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each Rng In Worksheets("xxxxxxxxxx").Activate
If Rng.Name <> tbl.Parent.Name Then
Rng.Cells.replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next Rng
Next x
End Sub
I have adjusted your code which you can see below; couple notes:
1- Using Option Explicit is always a good idea
2- If you put the array loop inside the sheet loop, you only have to perform the sheet name check n times (n=number of sheets in workbook), if you put the sheet loop inside the array loop you would have to perform the sheet name check n*x times (x = number of items in your array)...
3- You didn't specify, but I assumed that your Table1 was structured vertically with the lookup value in the first column and the replacement value in the 2nd- so there is no need to transpose your array; if your Table1 is in fact horizontal then you would need to adjust this code...
Public Sub demoCode()
Dim sheetName As String
Dim tableRange As Range
Dim myArray() As Variant
Dim wsCounter As Long
Dim rowCounter As Long
'Store name of sheet with lookup table
sheetName = "How to"
'Create an Array out of the Table's Data
Set tableRange = ThisWorkbook.Sheets(sheetName).ListObjects("Table1").DataBodyRange
myArray = tableRange
'Loop through each sheet
For wsCounter = 1 To ThisWorkbook.Sheets.Count
With ThisWorkbook.Sheets(wsCounter)
'Test to make sure the sheet is not the sheet with the lookup table
If .Name <> sheetName Then
'Loop through each item in lookup table
For rowCounter = LBound(myArray, 1) To UBound(myArray, 1)
'Replace any cells that contain whats in the first column of the lookup table, with whats in the 2nd column..
.Cells.Replace What:=myArray(rowCounter, 1), Replacement:=myArray(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End If
End With
Next
End Sub
Hope this helps,
TheSilkCode
so to answer your second question, basically what you would need to do is remove the sheet loop (which you have done), and then the part you're missing is you also need to specify you want the code to perform the replace on just the cells within the target range, instead of performing it on the cells within the sheet (which would be all the cells)... see below for example:
Public Sub demoCode_v2()
Dim tableRange As Range
Dim myArray() As Variant
Dim rowCounter As Long
Dim targetRange As Range
'Create an Array out of the Table's Data
Set tableRange = ThisWorkbook.Sheets(sheetName).ListObjects("Table1").DataBodyRange
myArray = tableRange
'Select target range
Set targetRange = Application.InputBox("Select target range:", Type:=8)
'Loop through each item in lookup table
For rowCounter = LBound(myArray, 1) To UBound(myArray, 1)
'Replace any cells in target range that contain whats in the first column of the lookup table, with whats in the 2nd column..
targetRange.Cells.Replace What:=myArray(rowCounter, 1), Replacement:=myArray(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End Sub
Hope this helps,
TheSilkCode
Using a slight adjustment of TheSilkCode code you could loop through a worksheet as follows:
Option Explicit
Public Sub pDemo()
Dim vMappingTable() As Variant
Dim rowCounter As Long
'1) Create an Array out of the Old to New Name mapping
vMappingTable = wksMappings.ListObjects("tbl_Mapping").DataBodyRange
'2) Loops through desired sheet and replaces any cells that contain the first column val, with the 2nd column val...
With wksToReplace.Range("X:X")
For rowCounter = LBound(vMappingTable, 1) To UBound(vMappingTable, 1)
.Cells.Replace What:=vMappingTable(rowCounter, 1), Replacement:=vMappingTable(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End With
End Sub
Note: you can define names of table via the Name manager (Ctrl+F3) and you can set the name of worksheets in your project in the properties in the VBA editor which I have done here or use the default names/and or path.
The code below is meant to read columns from an Excel table into arrays, which can then be used to determine whether each "Project" belongs to the Environment "Group", and if so, to add the project number and dollar value to another array. I am having some issues with my code, and have been searching the internet and StackOverflow but have been able to find very little information on dealing with Excel Tables using VBA. I am using Excel 2010.
Sub UpdateProjectsAndCharges()
'Define arrays to be used
Dim projectArray() As Variant
Dim uniqueProjectArray(100) As Variant
Dim dollarValue() As Variant
Dim envProjectArray(100) As Variant
Dim envDollarValue(100) As Double
Dim cumulativeCosts(100) As Double
'Define all tables in this sheet as list objects
Dim UnitsValues As ListObject
Dim ChargingTracking As ListObject
'Define counters to be used
Dim counter As Integer
Dim counter2 As Integer
'Set variables for each table in sheet
Set UnitsValues = Sheets("Cluster Data").ListObjects("UnitsValues")
Set ChargingTracking = Sheets("Cluster Data").ListObjects("ChargingTracking")
'Find last row in table
With Sheets("Cluster Data")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
End With
'Define variables to be used in loops
Dim userGroup As Variant
Dim project As Variant
Dim Value As Variant
'Set arrays to respective columns from UnitsValues table
userGroups = Range("UnitsValues[Group]")
projectArray = Range("UnitsValues[Project]")
dollarValue = Range("UnitsValues[Dollar Value]")
'Redefine length of arrays to number of rows in table
ReDim Preserve projectArray(lastRow)
ReDim Preserve dollarValue(lastRow)
'Set counter values
counter = 1
counter2 = 1
For Each userGroup In userGroups
project = projectArray(counter)
Value = dollarValue(counter)
If userGroup = "Environment" Then
envProjectArray(counter2) = project
envDollarValue(counter2) = Value
counter2 = counter2 + 1
MsgBox ((envProjectArray(counter2) & " " & envDollarValue(counter2)))
End If
counter = counter + 1
Next userGroup
I was receiving the "Subscript out of range" error with these lines:
project = projectArray(counter)
Value = dollarValue(counter)
I looked up the error and thought that these lines would perhaps fix the problem:
ReDim Preserve projectArray(lastRow)
ReDim Preserve dollarValue(lastRow)
Now, I am receiving the same error on the lines above instead, and have run out of ideas on how to fix the error. I suspect it is happening because I assigned a range into an array, but I'm not certain.
Change:
project = projectArray(counter)
Value = dollarValue(counter)
to
project = projectArray(counter, 1)
Value = dollarValue(counter, 1)
Arrays read from worksheets always are multidimensional even if you just have 1 column.
In this case you are specifying that column to be 1, every time.
I have an excel Sheet1 of a thousand of rows and 20 columns from A1 to T1. Each cell in that range has some data in it, usually one or two words.
In Sheet2, A1 column I have a list of data of 1000 values.
I am working on VBA script to find words from Sheet2 list in Sheet1 and clear the values of the cells of the found ones.
I now have a VBA script that works only on A1 column of Sheet1 and it deletes the rows only. Here's the script:
Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
With Worksheets("Sheet1")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rList = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
Worksheets("Sheet1").ShowAllData
rList(1).Delete shift:=xlUp: rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub
Could anyone help me? I need the values cleared, not rows deleted, and this should work on all columns of Sheet1, not just A1.
Here is another method using an array by minimizing the traffic between sheet (iteration via range/cells) and code. This code doesn't use any clear contents. Simply take the whole range into an array, clean it up and input what you need :) with a click of a button.
edited as per OP's request: adding comments and changing the code for his desired sheets.
Code:
Option Explicit
Sub matchAndClear()
Dim ws As Worksheet
Dim arrKeys As Variant, arrData As Variant
Dim i As Integer, j As Integer, k As Integer
'-- here we take keys column from Sheet 1 into a 1D array
arrKeys = WorksheetFunction.Transpose(Sheets(1).Range("A2:A11").Value)
'-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
arrData = WorksheetFunction.Transpose(Sheets(2).Range("C2:D6").Value)
'-- here we iterate through each key in keys array searching it in
'-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
'-- when there's a match we clear up that element
If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeys(i))) Then
arrData(1, j) = " "
End If
'-- when there's a match we clear up that element
If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeys(i))) Then
arrData(2, j) = " "
End If
Next j
Next i
'-- replace old data with new data in the sheet 2 :)
Sheets(2).Range("C2").Offset(0, 0).Resize(UBound(arrData, 2), _
UBound(arrData)) = Application.Transpose(arrData)
End Sub
Please not that you what you really need to set here are the ranges:
Keys range
To-Be-Cleaned up range
Output: (for displaying purpose I am using the same sheet, but you can change the sheet names as you desire.
Edit based on OP's request for running OP's file:
The reason that it didn't clean all your columns is that in the above sample is only cleaning two columns where as you have 16 columns. So you need to add another for loop to iterate through it. Not much performance down, but a little ;) Following is a screenshot after running your the sheet you sent. There is nothing to change except that.
Code:
'-- here we iterate through each key in keys array searching it in
'-- to-be-cleaned-up array
For i = LBound(arrKeys) To UBound(arrKeys)
For j = LBound(arrData, 2) To UBound(arrData, 2)
For k = LBound(arrData) To UBound(arrData)
'-- when there's a match we clear up that element
If UCase(Trim(arrData(k, j))) = UCase(Trim(arrKeys(i))) Then
arrData(k, j) = " "
End If
Next k
Next j
Next i
I don't have excel to hand right now so this may not be exactly 100% accurate on formulae name but I believe this line needs to change:
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
to
rList.Offset(1).ClearContents
once you've set rList to your desired selection. Delete is the reason you're deleting rows and not clearing them. (1) is the reason you were doing A1 only instead of entire range.
EDIT
The final code that I tested this with was (includes going over all columns now):
Option Explicit
Sub DeleteEmails()
Dim rList As Range
Dim rCrit As Range
Dim rCells As Range
Dim i As Integer
With Worksheets("Sheet2")
.Range("A1").Insert shift:=xlDown
.Range("A1").Value = "Temp Header"
Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
End With
Set rCells = Sheet1.Range("$A$1:$T$1")
rCells.Insert shift:=xlDown
Set rCells = rCells.Offset(-1)
rCells.Value = "Temp Header"
For i = 1 To rCells.Count
Set rList = Sheet1.Range(rCells(1, i).address, Sheet1.Cells(Rows.Count, i).End(xlUp))
If rList.Count > 1 Then 'if a column is empty as is in my test case, continue to next column
rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
rList.Offset(1).ClearContents
Worksheets("Sheet1").ShowAllData
End If
Next i
rCells.Delete shift:=xlUp
rCrit(1).Delete shift:=xlUp
Set rList = Nothing: Set rCrit = Nothing
End Sub
PS: may I request that you do not use ':' in vba. Its really hard to notice in vba's default IDE and took me a while to figure why things were happening but not making sense!