I am trying to get an array of values inside column A of Sheet 'Codes' and then get an array of all Sheets whose name starts with 'Price_Plan'*
My Start_Click Button is in a Sheet Named 'Macro' and I am trying to get data from column 'A' of Sheet named 'Codes'.
Private Sub Start_Click_Click()
Dim wS As Worksheet, LastRow As Long
Dim codeArray As Variant
Dim lastCell As String
Dim curSheet As Worksheet
Dim ArraySheets() As String
Dim x As Variant
Set wS = ThisWorkbook.Worksheets("Codes")
'Here we look in Column A
LastRow = wS.Cells(wS.Rows.Count, "A").End(xlUp).Row
lastCell = "A" & Str(LastRow)
'Here we create array of our row values
ThisWorkbook.Sheets("Codes").Activate
Set codeArray = ActiveSheet.range("A2:" & lastCell).Value
'Getting Array of Price Plan Sheets
For Each curSheet In ActiveWorkbook.Worksheets
If curSheet.Name Like "Price_Plan*" Then
ReDim Preserve ArraySheets(x)
ArraySheets(x) = curSheet.Name
x = x + 1
End If
Next curSheet
End Sub
I get this Runtime Error at:
Set codeArray = ActiveSheet.range("A2:" & lastCell).Value
Related
I am trying to add values from a specific range(column) into a listbox. However, the range has blank cells and duplicates that I am trying to get rid of. The following code works (no error msg) and does populate the listbox, but it does not get rid of the duplicates.
Can someone help?
Private Sub UserForm_Initialize()
Dim rang, rang1 As Range
Dim lstrow As Long
Dim list(), ListUniq() As Variant
Dim iRw As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Paramed Verification Grid")
Set rang = ws.Range("E3").CurrentRegion
lstrow = rang.Rows.Count + 1
Set rang1 = Range("E3:E" & lstrow)
'list = ws.Range("E3:E" & lstrow).SpecialCells(xlCellTypeConstants)
'Resize Array prior to loading data
ReDim list(WorksheetFunction.CountA(rang1))
'Loop through each cell in Range and store value in Array
x = 0
For Each cell In rang1
If cell <> "" Then
list(x) = cell.Value
x = x + 1
End If
Next cell
ListUniq = WorksheetFunction.Unique(list)
ListUniq = WorksheetFunction.Sort(ListUniq)
ProviderListBx.list = ListUniq
End Sub
I have tried to fix a code from the answers that I have found in the forum, but I can't manage.
My issue is:
I have a list of recipes names in the sheet weeks, and I want to decide with a 1 or a 0 which ones I want to meal prep for next week. In sheet Recipes, I have the Recipes listed with their ingredients list below. I would like to have an output of what I need to shop in Sheet 5.
In sheet Weeks If column B = 1, take recipe name in column A; Hlookup recipe name in sheet Recipes row 3, and return list of ingredients below to sheet 3 (the shopping list).
Sub Output_Shoopinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Weeks")
Dim LastRow As Long ' get last used row in column b
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B3", "C20" & LastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets("Recipes")
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets("Shopping list")
'Lookup Value in Tab Recipes in row 3, and return Ingrediants list one below the other in tab Shopping list in Column B
'Here I am missing code:
End Sub
Here are some screenshots:
I have left comments in few area to explain what the code is doing in general.
As mentioned in the comment - The basic idea is to perform a Find method along the row containing the recipe name and if it is found, the column number of the found cell will be used to pull out the list of ingredients (and the amount that is 1 column before) that is written below the recipe names.
Once the list has been retrieved in an array, it will be used to write into the shopping list worksheet at once.
Option Explicit
Const WSNAME_WEEK As String = "Weeks"
Const WSNAME_RECIPES As String = "Recipes"
Const WSNAME_SHOPPING As String = "Shopping list"
Sub Output_Shoppinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets(WSNAME_WEEK)
Dim lastRow As Long ' get last used row in column b
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B4:C" & lastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
If OutputData.Count <> 0 Then
' Uncomment if you need to clear the shopping list prior to inserting this batch of list of ingredients
' With ThisWorkbook.Worksheets(WSNAME_SHOPPING)
' Dim shoppingLastRow As Long
' shoppingLastRow = .Cells(.Rows.Count, 2).Row
' .Range("A2:B" & shoppingLastRow).Value = ""
' End With
'1. Loop through the collection,
'2. Pass the recipe name to GetIngredients to retrieve the list of ingredients (in an array) from Recipes worksheet
'3. Pass the array to WriteToShoppingList for writing into the Shopping list worksheet
Dim i As Long
For i = 1 To OutputData.Count
'Get the ingredient list from Recipes sheet
Dim ingredList As Variant
ingredList = GetIngredients(OutputData(i))
If Not IsEmpty(ingredList) Then WriteToShoppingList ingredList
Next i
End If
MsgBox "Done!"
End Sub
Function GetIngredients(argRecipeName As String) As Variant
Const firstRow As Long = 7 'Change this to whichever row the first ingredient should be on
Const recipesNameRow As Long = 3
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets(WSNAME_RECIPES)
'==== Do a Find on row with the recipe names
Dim findCell As Range
Set findCell = wsTemplate.Rows(recipesNameRow).Find(argRecipeName, LookIn:=xlValues, LookAt:=xlWhole)
If Not findCell Is Nothing Then
'==== If found, assign the value of the ingredients (from firstRow to the last row) into an array
Dim lastRow As Long
lastRow = wsTemplate.Cells(firstRow, findCell.Column).End(xlDown).Row
Dim ingredRng As Range
Set ingredRng = wsTemplate.Range(wsTemplate.Cells(firstRow, findCell.Column), wsTemplate.Cells(lastRow, findCell.Column)).Offset(, -1).Resize(, 2)
Dim ingredList As Variant
ingredList = ingredRng.Value
GetIngredients = ingredList
End If
End Function
Sub WriteToShoppingList(argIngredients As Variant)
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets(WSNAME_SHOPPING)
Dim lastRow As Long
lastRow = wsVolume.Cells(wsVolume.Rows.Count, 2).End(xlUp).Row
wsVolume.Cells(lastRow + 1, 1).Resize(UBound(argIngredients, 1), 2).Value = argIngredients
End Sub
I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub
Hello VBA Developers,
I am having a hard time solving a multi-wildcard filter for criteria(s) listed in an array. The code stops at "vTst = Doc_ID_Arr(i)", stating vTst = Empty. However, checking Doc_ID_Arr is not empty if you check the debugger.
Sub doc_id()
'Segment 1 ----
'Get the worksheet called "LOB Docs"
Dim sh_1 As Worksheet
Set sh_1 = ThisWorkbook.Worksheets("LOB Docs")
' Declare an array to hold all LOB Doc ID numbers
Dim Doc_ID_Arr As Variant
Dim Doc_ID_Value As String
Dim j As Long
Dim i As Long
With sh_1
lastrow_Header_Config = sh_1.Cells(Rows.count, "A").End(xlUp).Row
' Read LOB DOC ID's from Column Cell A2 to last value in Column A
ReDim Doc_ID_Arr(Application.WorksheetFunction.CountA(sh_1.Range("A2:A" & lastrow_Header_Config)) - 1) As Variant
j = 0
For i = 2 To lastrow_Header_Config
Doc_ID_Value = sh_1.Range("A" & i).Value
If Doc_ID_Value <> "" Then
Doc_ID_Arr(j) = "*" & Doc_ID_Value & "*"
j = j + 1
End If
Next
End With
' ' Debug.Print "Doc_ID_Value"
' For i = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
' Debug.Print Doc_ID_Arr(i)
' Next i
'Segment 2 ----
Dim sh_2 As Worksheet 'Data Sheet
Dim sh_3 As Worksheet 'Output Sheet
Set sh_2 = ThisWorkbook.Worksheets("GDL db") 'Data Sheet
Set sh_3 = ThisWorkbook.Worksheets("Seed Template Output")
Dim Dic As Object
Dim eleData As Variant
Dim eleCrit As Variant
Dim ArrData As Variant
Dim vTst As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Dim x As Long
For x = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
vTst = Doc_ID_Arr(i)
Next x
With sh_2
.AutoFilterMode = False
ArrData = .Range("A1:A" & .Cells(.Rows.count, "A").End(xlUp).Row)
For Each eleCrit In vTst
For Each eleData In ArrData
If eleData Like eleCrit Then _
Dic(eleData) = vbNullString
Next
Next
.Columns("A:A").AutoFilter Field:=1, Criteria1:=Dic.Keys, Operator:=xlFilterValues
sh_2.UsedRange.Copy sh_3.Range("A1")
End With
End Sub
I am trying to filter sh_2, Column A for each value(individual) or all values(en masse) that is placed in the Doc_ID_Arr created in Segment 1. The target is to place each filter output for each ID onto sh_3, without overwriting previous placed values/rows.
Using your previously-posted sample workbook this works for me:
Sub document_link_extract()
'Define data source
Dim GDL_Data As Worksheet 'Datasheet holding Docs links
Dim LOB_Doc As Worksheet 'Docs to filter for
Dim Doc_Output_sh As Worksheet 'Seed Template - curated document list
Dim Doc_ID_List() As String, v, rngIds As Range
Dim arrVals, arrSearch, dict, rwV As Long, rwS As Long, srch
Set GDL_Data = ThisWorkbook.Sheets("Sheet2") 'DataSheet
Set LOB_Doc = ThisWorkbook.Sheets("Sheet1") 'Filter Criteria Sheet
Set Output_sht = ThisWorkbook.Sheets("Sheet3") 'Output for' Look 1/2 - URL Check & PDF Extract
Output_sht.UsedRange.Clear
'get array of search terms
With LOB_Doc
arrSearch = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
'get array of data column values
With GDL_Data
arrVals = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
Set dict = CreateObject("scripting.dictionary")
'loop over each search term
For rwS = 1 To UBound(arrSearch, 1)
srch = "*" & arrSearch(rwS, 1) & "*" '<< search term with wildcards
'loop over each value
For rwV = 1 To UBound(arrVals, 1)
v = arrVals(rwV, 1)
'if value matches search term then add to dictionary
If v Like srch Then dict(v) = True
Next rwV
Next rwS
GDL_Data.AutoFilterMode = False 'if there is any filter, remove it
'filter using the dictionary keys array
GDL_Data.UsedRange.AutoFilter 1, dict.keys, xlFilterValues
GDL_Data.UsedRange.Copy Output_sht.Range("A1")
GDL_Data.AutoFilterMode = False
End Sub
I'm trying to copy rows from master table sheet to different sheets based on the value of the cell in the column:
The column "AL" contains several values (validation list) for example dog, cat, giraffe, I'd like to automatically open new sheet for every value and copy the relevant rows to the new sheet. (the new sheets must have the name of the value).
In addition when a new data is added, I need the new rows to be added to the correct sheet.
Sub Copy_Data()
Dim r As Range, LastRow As Long, ws As Worksheet
Dim v As Variant, s As String, LastRow1 As Long
Dim src As Worksheet
Set src = Sheets("Sheet1")
LastRow = src.Cells(Cells.Rows.Count, "AL").End(xlUp).Row
'Change these to your strings to copy
s = "dog,cat,fish,giraffe"
v = Split(s, ",")
For Each r In src.Range("AL1:AL" & LastRow)
If Not IsError(Application.Match(CStr(r.Value), v, 0)) Then
On Error Resume Next
Set ws = Sheets(CStr(r.Value))
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r.Value)
LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "AL").End(xlUp).Row
src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
Set ws = Nothing
Else
LastRow1 = Sheets(CStr(r.Value)).Cells(Cells.Rows.Count, "Al").End(xlUp).Row
src.Rows(r.Row).Copy Sheets(CStr(r.Value)).Cells(LastRow1 + 1, 1)
Set ws = Nothing
End If
End If
Next r
End Sub