find and replace values in database using an array VBA - arrays

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.

Related

Excel VBA Find a value within a cell from an array and return value to new column

Good day, I am a newbie to VBA. I have not included the code I have tried, because nothing has even come close.
I have a Data range of about 10,000 that contains the building, department, user name and possibly other information. This information is in column B. The names are not in the same location of each cell and they can be any case and can contain up to 4 words.
I have a Named Range (Full Name) of about 14,000 names in a separate workbook named database.
I need to see if the names show up in the data range list and if so populate column C with the name.
Thanks in advance for any assistance.
Example code:
Sub Full_Name()
Dim iWs As Worksheet, iFn As Variant, lastrow As Long, iDB As Worksheet
iFn = Range("'[Shadow Datafie Database.xlsx]EMCP'!Full_Name").Value
Set iWs = ActiveWorkbook.Worksheets("EMCP")
lastrow = iWs.UsedRange.Rows.Count + 1
For i = 2 To lastrow
If InStr(iWs.Cells(i, 2), iFn) > 0 Then
iWs.Cells(i, 3) = iFn
End If
Next
End Sub
This code may work for you:
It assumes your list of names is in an Excel table called Table1.
Sub FindName()
'Open the csv file containing your information - building, department, etc.
Dim wrkBkSrc As Workbook
Set wrkBkSrc = Workbooks.Open("<path to your file>\Numplan(11).csv")
'A csv file will only contain a single sheet, so can reference it by sheet position - first and only.
With wrkBkSrc.Worksheets(1)
Dim DataRange As Range
Set DataRange = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
' *** OLD CODE ***
' With ThisWorkbook.Worksheets("Sheet1")
' Dim DataRange As Range
' Set DataRange = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
' End With
'Open the database file and set reference to it.
Dim wrkBk As Workbook
Set wrkBk = Workbooks.Open("<path to your file>\Database.xlsx")
'Set reference to the names table.
'Note: This is an Excel table, not an Excel range.
' Press Ctrl+T to turn range into a table.
Dim NameTable As ListObject
Set NameTable = wrkBk.Worksheets("Database").ListObjects("Table1")
'Only continue if there's data in the table.
If Not NameTable.DataBodyRange Is Nothing Then
Dim NameItm As Range
Dim FoundItm As Range
For Each NameItm In NameTable.DataBodyRange
'Find the name within the DataRange.
Set FoundItm = DataRange.Find( _
What:=NameItm, _
After:=DataRange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'If it's found place the name in the next column along.
If Not FoundItm Is Nothing Then
FoundItm.Offset(, 1) = NameItm
End If
Next NameItm
End If
End Sub

Looping VBA ranges and offsetting to specific table column and other values

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

VBA - Find and replace multiple values using array

Below piece of code return " run time error 09 "
This code supposed to find and replace multiple values across worksheet ( removes brackets, replace words etc using fnd - rplc ). List of values to be find are populated in another sheet "Array" List of values to replace populated in another sheet "Array"
I want this code to check all values stored in sheet Array from column E down ( this list can be adjusted ) check if those values are populated inside worksheet "Control Panel" and replace them with values from "Array" column F down.
For below code i did apply "Array" Range but still return error. Any chance to get this running and have array lists flexible, so i can easily add "Find" & "Replace "values
Sub Multi_Find_Replace()
Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long
Dim fndTable As Range
Dim rplcTable As Range
Set sht = Sheets("Control Panel")
Set fndTable = ThisWorkbook.Sheets("Array").Range("E2:E10")
Set rplcTable = ThisWorkbook.Sheets("Array").Range("F2:F10")
fndList = fndTable
rplcList = rplcTable
For x = LBound(fndList) To UBound(fndList)
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Next x
End Sub

Issue with vlookup and absolute reference and lastrow VBA

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:

Excel subset column to an array using formula

I need to get the Account Numbers into an array which is indicated as 1 on the column select. Results expected is - {FD_002_17,FD_004_17}. I am planning to use this in a Name Range.
Table of interest to subset
I tried using
=INDEX(B2:B6,MATCH(1,A2:A6),1)
But this fails as Match does not return an array.
Using the post (https://stackoverflow.com/a/6755513/4050510) in the SO question that Hugs referred to i came up with the following formula for your need.
Its a array formula that you enter into your first cell, and then fill it downwards using the little handle in the corner of the selected cell.
=IFERROR(INDEX($B$2:$B$6;SMALL(IF($A$2:$A$6=1;ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1;"");ROW(A1)));"")
It is possible to do this. You can assign the named range to a formula such as :
=INDEX(Sheet1!$B:$B, N(IF({1}, MODE.MULT(IF(Sheet1!$A$2:$A$6=1, ROW(Sheet1!$A$2:$A$6)*{1,1})))))
Then you can reference your Named Range like: =INDEX(MyNamedRange, 2)
EDIT:
You can either set a hidden sheet to have a filtered list of the values in a range of cells, or else use VBA:
VBA:
Put this in the worksheet codemodule of the relevant work sheet:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Dim ARange As Range, BRange As Range
Dim i As Long, lastRow As Long, strCount As Long
lastRow = Me.Range("A" & Me.Rows.Count).End(xlUp).Row
Set ARange = Me.Range("A1:A" & lastRow)
Set BRange = Me.Range("B1:B" & lastRow)
Dim stringArr() As String
For i = 1 To lastRow
If ARange.Cells(i, 1).Value = 1 Then
ReDim Preserve stringArr(0 To strCount)
stringArr(strCount) = BRange.Cells(i, 1).Value
strCount = strCount + 1
End If
Next i
Dim str As String
str = Join(stringArr, ",")
Dim dv As Validation
Set dv = Me.Range("DVCell").Validation
If Not dv Is Nothing Then
dv.Modify _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=str
Else
dv.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=str
End If
End Sub
To use formulas and a hidden sheet, use the techniques to fill a range of cells, and then assign that dynamic range to the data validation....

Resources