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
Related
I have written a script to insert a range of cells into a list box of the userform in 3 steps:
The main table (A2:N...) gets filtered to a specific value in column A.
The values in column G get put into a range, then a sorted array with unique values.
The array is inputed in the listbox
I am getting the error 1004 regarding the "unique" function on rang1. I don't understand what is the issue.
Can someone kindly help me?
Private Sub UserForm_Initialize()
Dim rang, rang1, As Range
Dim lstrow, x As Long
Dim ListUniq(), ListNoEmpty(), As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim lr As Integer
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rang = ws.Range("B3").CurrentRegion
lstrow = rang.Rows.Count + 1
'Step1.The main table (A2:N...) get's filtered to a specific (Dental) value on column A.
ws.Range("$A$2:$N$" & lstrow).AutoFilter _
Field:=1, _
Criteria1:="Dental", _
Operator:=xlFilterValues
lr = Range("A" & Rows.Count).End(xlUp).Row
'Step2.The values in column G get put into a range, then a sorted array with unique values.
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
ReDim ListUniq(WorksheetFunction.CountA(rang2))
ListUniq = WorksheetFunction.Unique(rang1)
ListUniq = WorksheetFunction.sort(ListUniq)
'Resize Array prior to loading data
ReDim ListNoEmpty(WorksheetFunction.CountA(ListUniq))
'Step3.The array is inputed in the listbox
'Loop through each cell in Range and store value in Array
x = 0
For Each cell In ListUniq
If cell <> "" Then
ListNoEmpty(x) = cell
x = x + 1
End If
Next cell
ProviderListBx.list = ListNoEmpty
End Sub
Unique Values to Listbox
This will work for any version of Excel i.e. it doesn't use the Unique and Sort functions but it uses a dictionary and an ascending integer sequence in a helper column instead.
Option Explicit
Private Sub UserForm_Initialize()
PopulateProviderListBox
End Sub
Sub PopulateProviderListBox()
Const ProcName As String = "PopulateProviderListBox"
On Error GoTo ClearError
Application.ScreenUpdating = False
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") ' adjust!
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim fCell As Range: Set fCell = ws.Range("A2")
Dim rg As Range
With fCell.CurrentRegion
Set rg = fCell.Resize(.Row + .Rows.Count - fCell.Row, _
.Column + .Columns.Count - fCell.Column)
End With
' Expand the range by one column and reference it ('nrg').
Dim cCount As Long: cCount = rg.Columns.Count + 1
Dim nrg As Range: Set nrg = rg.Resize(, cCount)
' Write an ascending integer sequence to the (new) helper column.
Dim rCount As Long: rCount = rg.Rows.Count
nrg.Columns(cCount).Value = ws.Evaluate("=ROW(1:" & rCount & ")")
' Sort the new range by the lookup column ('7').
nrg.Sort nrg.Columns(7), xlAscending, , , , , , xlYes
' Reference the data (no headers) of the lookup column ('lrg').
Dim lrg As Range: Set lrg = nrg.Columns(7).Resize(rCount - 1).Offset(1)
' Filter the new range by the criteria in the criteria column ('1').
nrg.AutoFilter 1, "Dental"
' Attempt to reference all visible cells ('vrg') of the lookup column.
Dim vrg As Range
On Error Resume Next
Set vrg = lrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Turn off the autofilter.
ws.AutoFilterMode = False
If Not vrg Is Nothing Then
' Return the unique (sorted) values
' in the keys of a dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim vCell As Range
For Each vCell In vrg.Cells
dict(vCell.Value) = Empty
Next vCell
' Return the unique (sorted) values in the listbox.
If dict.Count > 0 Then ProviderListBx.List = dict.Keys
End If
' Sort the new range by the helper column to regain initial order.
nrg.Sort nrg.Columns(cCount), xlAscending, , , , , , xlYes
' Clear the helper column.
nrg.Columns(cCount).Clear
Application.ScreenUpdating = True
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Even if you Excel version accepts UNIQUE and Sort formulas and then WorksheetFunction methods, both of them do not behave exactly as Excel respective formulas...
WorksheetFunction.UNIQUE does not work on discontinuous ranges.
The next line, returns such a range:
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
Even ListUniq = WorksheetFunction.sort(rang1) does not work because of the above mentioned behavior. If ListUniq would be a continuous range it will work.
Then, declaring Dim ListUniq() makes useless the line ReDim ListUniq(WorksheetFunction.CountA(rang2)), which anyhow uses an non existing range. Probably, it is a type and it should be rang1, but still useless. VBA is able to return the array without needing a previous ReDim. Only the range to be continuous.
In such cases, a function transforming the discontinuous range in a continuous array would solve your issue:
Private Function ListUniqFromDiscR_2D(rng As Range) As Variant 'makes 2D (one column) array from a discontinuous range
Dim A As Range, ListUniq, count As Long, i As Long
ReDim ListUniq(1 To rng.cells.count, 1 To 1): count = 1
For Each A In rng.Areas
For i = 1 To A.cells.count
ListUniq(count, 1) = A.cells(i).Value: count = count + 1
Next
Next
ListUniqFromDiscR_2D = ListUniq
End Function
It can be used in your code as:
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
ListUniq = ListUniqFromDiscR_2D(rang1) 'the continuous extracted array
Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to visually see the (continuous) returned array
ListUniq = WorksheetFunction.unique(ListUniq) 'the unique elements array
ListUniq = WorksheetFunction.Sort(ListUniq) 'the unique sorted array
Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to the unique, sorted array (in Immediate Window)...
But if your Excel version is not able to handle Unique and Sort, there are not standard VBA functions doing it very fast. If this is your case, I can also post such functions.
I am writing a code that defines a named range based on a different set of columns. These columns are identified by all having the word "Dashboard" written in the same row.
The code works right now if I specify the exact columns (see below "C,E,H,O") but I am lost on how to have the code collect all matching columns and then creating the ColumnList from it.
Option Explicit
Sub Define_Chart_Range()
Dim ws As Worksheet
Dim lastRow As Long
Dim arrColumns As Variant
Dim strSelect As String
Dim i As Integer
Dim lnRow As Long, lnCol As Long
Dim myNamedRange As Range
Dim myRangeName As String
Set ws = ThisWorkbook.Sheets("Data_Range")
'finding all columns that have the word Dashboard in Row 3
lnRow = 3
lnCol = ws.Cells(lnRow, 1).EntireRow.Find(What:="Dashboard", _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False).Column
'Find the last used row in Column A
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
' Describe what columns you want to select
Const ColumnList As String = "C,E,H,O"
' Row to start at
Const StartAtRow As Long = 8
' Create an array to hold columns
arrColumns = Split(ColumnList, ",")
' Define first column to select
strSelect = arrColumns(0) & StartAtRow
' and add rows to last ne found above
strSelect = strSelect & ":" & arrColumns(0) & lastRow
' Add rest of columns to selection list
For i = 1 To UBound(arrColumns)
strSelect = strSelect & "," & arrColumns(i) & StartAtRow & ":" & arrColumns(i) & lastRow
Next i
' Defining name of Selected Columns as Named Range
Set ws = ThisWorkbook.Worksheets("Data_Range")
Set myNamedRange = ws.Range(strSelect)
'specify defined name
myRangeName = "Dashboard_Data"
'create named range with workbook scope. Defined name and cell range are as specified
ThisWorkbook.Names.Add Name:=myRangeName, RefersTo:=myNamedRange
End Sub
You can use Union to directly build a range, without needing to work with range addresses.
Sub Define_Chart_Range()
Const SearchRow As Long = 3
Const StartAtRow As Long = 8
Const RangeName As String = "Dashboard_Data"
Dim ws As Worksheet, lastRow As Long
Dim myNamedRange As Range, rng As Range, c As Range
Dim myRangeName As String
Set ws = ThisWorkbook.Sheets("Data_Range")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'loop cells in row to search...
For Each c In ws.Range(ws.Cells(SearchRow, 1), _
ws.Cells(SearchRow, Columns.Count).End(xlToLeft)).Cells
If LCase(c.Value) = "dashboard" Then 'want this column
'add to range
BuildRange myNamedRange, _
ws.Range(ws.Cells(StartAtRow, c.Column), ws.Cells(lastRow, c.Column))
End If
Next c
Debug.Print myNamedRange.Address
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=myNamedRange
End Sub
'utility sub to build up a range using Application.Union
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
I'm trying to reduce redundancy in my macros but I'm struggling with getting an element from a jagged array and using it elsewhere.
The premise is a single workbook with many sheets being split by groups of sheet names into new documents that I can then send to the process owners so they only get their own data.
Previously I was selecting sheet names listed explicitly and pasting to a new document that was named explicitly, but I had to run 10 separate almost identical macros to do that and I have heard of select being a bad choice in many instances as well.
Below is my latest attempt, the first issue is at the printOut line I get a Type Mismatch.
Sub CopyOut()
Dim printOut, groupNames, Group1, groupArray() As Variant
Dim n, j As Long
Dim reNamed, fileName As String
Dim ws As Worksheet
Dim wb1, wb2 As Workbook
groupNames = Array("Group 1", "Group 2", "Group 3", "Group 4") 'other arrays left off for length
Group1 = Array("FA_1A Report", "FA_1A", "FA_2ACS Report", "FA_2ACS", "FA_2BCS Report", "FA_2BCS", "FANUCMED Report", "FANUCMED", "FA_RRTP1 Report", "FA_RRPT1")
groupArray = Array(groupNames, Group1)
For n = 1 To UBound(groupArray)
fileName = "CS Data Sheet" & " " & Format(Date, "mmmyy") & "-" & groupArray(n - n)(n - 1) & ".xlsm" 'concat file name string. this is not just tacked on the end of reName because i use it on it's own later
reNamed = "C:\Users\xx\Desktop\" & fileName 'concat save location string
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add 'create a new workbook, wb2
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'save with that name and location
printOut = Join(Application.Index(groupArray, n, 0), ",")
wb1.Sheets(printOut).Copy Before:=Workbooks(fileName).Sheets(1) 'copy the sheets for the group and paste into the newly created document
Next
End Sub
If I nix printOut altogether and put in a specific worksheet name instead it does work for just that one sheet (of course) but I need it to copy multiple to each new document.
I have also tried:
For n = 1 To UBound(groupArray)
...
for j= LBound(groupArray(n)) To UBound(groupArray(n))
wb1.Sheets(groupArray(n)(j)).Copy Before:=Workbooks(fileName).Sheets(1)
next
next
to iterate through the subarray and copy a sheet at a time, but it gives subscript out of range. With this version I tried various methods of making the groupArray(n)(j) value into a string or into a "worksheet" type to set as a variable and use the variable in the sheets().copy, to no avail.
Any idea where I could be going wrong?
thanks so much
EDIT:
I got my above code working by wrapping it in split (was trying to use printOut as an array when it was only a string) and fixing the arguments of Index as below, however the resulting code still needs work, since if a sheet is missing it won't run.
printOut = Split(Join(Application.Index(groupArray(n), 1, 0), ","), ",")
In my experience, if you find yourself hard-coding values like sheet names, group names, and other data directly in your code it tends to become difficult to maintain. Adding more groups, or re-shuffling the sheets in each group becomes problematic. My recommendation is to create a (possibly hidden) worksheet that maps your worksheet names into groups. Then you have a small set of code that operates directly on that.
My example data is set up like this:
Next, in its own code module, I created a few methods to work directly with this group map data. The main idea here is to move the group map data into a memory-based array. While in general I rarely use module-level global variables, I have one in this example to illustrate how to work with the data by only reading it into the array once every time the macro is executed.
(These are Subs and Functions. For my own code, I likely would have created a VBA class to handle the data in an object-oriented way.)
So there is a Private Sub to get the data:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Now it's easy to figure out how many groups there are:
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
And how many items in a particular group:
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
The easiest of all is getting the value of any group:
Public Function GetGroupValue(ByVal groupNumber As Long, _
ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
Notice the check for If IsEmpty(groupData) Then GetGroupData at the beginning of each method. This makes sure the groupData array is always loaded if necessary.
This example gives it a quick test (in a different code module):
Option Explicit
Sub test()
Dim totalGroups As Long
totalGroups = NumberOfGroups()
Dim i As Long
Dim j As Long
For i = 1 To totalGroups
Dim totalInGroup As Long
totalInGroup = NumberInGroup(i)
For j = 1 To totalInGroup
Debug.Print "group " & i & " = " & GetGroupValue(i, j)
Next j
Next i
End Sub
Here's the whole group data code module in a single block:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
Public Function GetGroupValue(ByVal groupNumber As Long, ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
If I got this right, you have one master workbook with n sheets and you want to group some of them, then create a new workbook for each group and paste in its assigned sheets.
I think an approach where you keep a "config" file in your master workbook for setting up groups and sheets, is more suitable rather than editing into code. Example:
The below code will create a file using the names from column A and copy all the sheets defined on their respective row.
Option Explicit
Sub CopyOut()
Dim groupArr() As Variant
Dim wb2 As Workbook
Dim lastRow As Long, lastCol As Long, highestNumOfSheets As Long, i As Long, j As Long, arrColumns As Long
Dim reNamed As String, fileName As String, configSheet As String
Dim removedSheet1 As Boolean
' Modify the sheet name here
configSheet = "config"
' Build an array from sheet defined groups
With ThisWorkbook.Worksheets(configSheet)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
If lastCol > highestNumOfSheets Then highestNumOfSheets = lastCol
Next i
groupArr = .Range(.Cells(2, 1), .Cells(lastRow, highestNumOfSheets)).Value2
End With
Application.ScreenUpdating = False
For i = LBound(groupArr) To UBound(groupArr)
fileName = "CS Data Sheet " & Format(Date, "mmmyy") & "-" & groupArr(i, 1) & ".xlsm"
reNamed = Environ("UserProfile") & "\Desktop\" & fileName
removedSheet1 = False ' Reset this on each new workbook created
Set wb2 = Workbooks.Add
' Pick all the sheet names for the current group
For j = 2 To UBound(groupArr, 2)
' Skip empty values from array (if it's the case) and skip missing sheets
If Trim(groupArr(i, j)) <> vbNullString And SheetExists(groupArr(i, j)) Then
ThisWorkbook.Worksheets(groupArr(i, j)).Copy Before:=wb2.Worksheets(1)
' Remove Sheet1 from the new Workbook
If removedSheet1 = False Then
With Application
.DisplayAlerts = False
wb2.Worksheets("Sheet1").Delete
removedSheet1 = True
.DisplayAlerts = True
End With
End If
End If
Next j
' Here you might need an error handler if you think you're going to run the macro multiple times in the same day
' If the file exists already this will throw an error
' A quick lazy way is to add time (including seconds) when you define the file name above
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb2.Close
If Not wb2 Is Nothing Then Set wb2 = Nothing
Next i
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If Not ws Is Nothing Then
SheetExists = True
Set ws = Nothing
End If
End Function
Of course it can be tweaked around, with error handling and other checks (depending on what you want to achieve entirely) but it should give you an alternative view of your code.
EDIT: Added a function to check if sheet exists.
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.
Can anybody help me edit? I want to copy from column to another workbook column using array.
The range inside the array is the Alphabet of the column i want to copy/paste.
Sub setting2()
Dim wb As ThisWorkbook
Dim here As Workbook
Dim there As Workbook
Dim source() As Variant
Dim log() As Variant
Dim LastRowHere() As Integer
Dim LastRowThere() As Integer
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
Windows("Setting.xlsm").Activate
source() = Array(Sheets("Sheet1").Range("E11"), Range("E12"), Range("E13"), Range("E14"), Range("E15"), Range("E16"),Range("E17").Value)
Windows("Setting.xlsm").Activate
log() = Array(Sheets("Sheet1").Range("J11"), Range("J12"),Range("J13"),Range("J14"), Range("J15"), Range("J16"), Range("J17").Value)
Windows("Setting2.xlsm").Activate
LastRowHere() = Array(Sheets("Sheet1").Rows.Count, source().End(xlUp).Row)
Windows("Setting3.xlsm").Activate
LastRowThere() = Array(Sheets("Sheet1").Rows.Count, log()).End(xlUp).Row
For i = 1 To LastRowHere()
LastRowThere(1) = there.Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count.log(1)).End(xlUp).Row
For k = 1 To LastRowThere()
'here.Sheets("Sheet1").Cells(i, k).Copy Destination:=there.Sheets("Sheet1").Cells(i, k)
here.Sheets("Sheet1").Rows(i).Columns(source(1)).Copy Destination:=there.Sheets("Sheet1").Rows(k + 1).Columns(log(1))
Next k
Next i
End Sub
Your problem is source().End(xlUp).Row. You're trying to use it as a range - which it's not. That is giving you the error.
You'd be better to populate your array by using a loop. And, unless you really want to carry the cell formatting across to the destination sheet, better not to use Copy since then you don't have to activate the destination sheet.
Not sure if the code below exactly fits your need. I wasn't sure of the purpose of log() array so I've left it out. The below copies the values of a single column from Source sheet to Destination sheet.
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
SourceCol = 5 'Column E from your example
Set SourceSht = here.Sheets(1)
Set DestnSht = there.Sheets(1)
With SourceSht
'Get last cell in the column
LastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
With DestnSht
'Get last cell in the column
DestnLastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
'Loop through all cells (assumes row 1 is header)
For r = 2 to LastRow
'Assign value from Source to Destination sheet
i = i + 1
DestnSht.Cells(DestnLastRow + i, SourceCol) = SourceSht.Cells(r, SourceCol)
Next
Try this.
I assume you need copy the value from range E11 to E17 and J11 to J17
Option Explicit
Dim CurrentWorkbook As Workbook
Dim SourceWorkbook As Workbook
Dim DestWorkbook As Workbook
Dim CurrentWorksheet As Worksheet
Dim SourceWorksheet As Worksheet
Dim DestWorksheet As Worksheet
Sub setting2()
Dim SourceLastRow As Long
Dim DestLastRow As Long
Set CurrentWorkbook = ActiveWorkbook
Set CurrentWorksheet = CurrentWorkbook.ActiveSheet
Set SourceWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx") 'change to your path
Set DestWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx") 'change to your path
Set SourceWorksheet = SourceWorkbook.Sheets(1)
Set DestWorksheet = DestWorkbook.Sheets(1)
SourceLastRow = SourceWorksheet.Cells(Rows.Count, "E").End(xlUp).Row
DestLastRow = DestWorksheet.Cells(Rows.Count, "J").End(xlUp).Row + 1
SourceWorksheet.Range("E11:E17").Copy Destination:=DestWorksheet.Range("E" & DestLastRow + 1) 'Change to the column you want
SourceWorksheet.Range("J11:J17").Copy Destination:=DestWorksheet.Range("J" & DestLastRow + 1) 'Change to the column you want
End Sub