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....
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 think i've got a good start, but I'm having a tough time taking this to the finish line. Could someone help me out?
I have a name column(G) in my spreadsheet. I want to pull the only the last name out of each cell and assign it to an array called name_array.
I know that my If function is working because if I set each name_cell to the LastName variable it substitutes only the lastname in each cell of the column, but I cannot figure out how to assign that to the array.
Here is my code thus far. Can someone please help me out and point out what I'm missing?
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(name_range.Cells.Count)
For Each name_cell In name_range.Cells
Dim Lastname As String
If InStr(name_cell, " ") > 0 Then
Lastname = Split(name_cell, " ")(1)
End If
name_array(n) = lastname.value
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Name Column
Here is another way to achieve what you want without looping. I have commented the code so you should not have a problem understanding it.
BASIC LOGIC
To get the part after SPACE, you can use the formula =IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")
Now applying the formula in the entire range and getting the value using INDEX(FORMULA). You can find the explanation of this method in Convert an entire range to uppercase without looping through all the cells
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long, i As Long
Dim FinalAr As Variant
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("G2:G" & lRow)
'~~> Get all the last names from the range and store them
'~~> in an array in 1 go!
FinalAr = Evaluate("index(IFERROR(MID(" & _
rng.Address & _
",SEARCH("" ""," & _
rng.Address & _
",1),LEN(" & _
rng.Address & _
")-SEARCH("" ""," & _
rng.Address & _
",1)+1),""""),)")
End With
'~~> Check the output
For i = LBound(FinalAr) To UBound(FinalAr)
Debug.Print ">"; FinalAr(i, 1)
Next i
End Sub
IN ACTION
ALTERNATIVE METHODS
Use Text To columns and then store the output in an array
Use Flash Fill to get the last names and then store the output in an array. One drawback of this method is that the names which do not have last name, it will show first name instead of a blank.
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(0 to name_range.Cells.Count-1) '### 0-based array...
For Each name_cell In name_range.Cells
If InStr(name_cell, " ") > 0 Then
name_array(n) = Split(name_cell, " ")(1) 'simplify...
End If
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Solution using Filter() (values with missing lastnames are excluded):
Sub ExtractLastNames()
Dim arr, name_array, i
arr = WorksheetFunction.Transpose(Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)) 'first, get the horizontal one-dimentional array from cells
name_array = Filter(arr, " ", True) 'second, filter out one-word and empty elements
For i = LBound(name_array) To UBound(name_array)
name_array(i) = Split(name_array(i))(1) 'third, replace name_array values with extracted lastnames
Next
Range("H2").Resize(UBound(name_array) + 1) = WorksheetFunction.Transpose(name_array) ' output
End Sub
Last Names to Array
The following will consider the substring after the last occurring space as the last name.
Option Explicit
Sub create_namear()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim nRange As Range
Set nRange = ws.Range("G2:G" & ws.Range("G" & ws.Rows.Count).End(xlUp).Row)
Dim rCount As Long: rCount = nRange.Rows.Count
Dim nArray() As String: ReDim nArray(0 To rCount - 1)
Dim nCell As Range
Dim n As Long
Dim nmLen As Long
Dim LastSpacePosition As Long
Dim nmString As String
Dim LastName As String
For Each nCell In nRange.Cells
nmString = CStr(nCell.Value)
If InStr(1, nmString, " ") > 0 Then
LastSpacePosition = InStrRev(nCell.Value, " ")
nmLen = Len(nmString)
If LastSpacePosition < nmLen Then
LastName = Right(nmString, nmLen - LastSpacePosition)
nArray(n) = LastName
n = n + 1
End If
End If
Next nCell
If n = 0 Then Exit Sub
If n < rCount Then
ReDim Preserve nArray(0 To n - 1)
End If
Debug.Print "[" & LBound(nArray) & "," & UBound(nArray) & "]" _
& vbLf & Join(nArray, vbLf)
End Sub
Extension on Siddharth' s formula evaluation
These additions to Siddharth's valid code can be helpful, if there are less than 2 data rows in order to avoid
an unwanted evaluation of the title row 1:1 (in case of no data at all, see section 1.b) - This can be prevented by correcting a resulting row number lRow of only 1 to the actual data row start of 2.
Error 9 Subscript out of range (in case of a single element; see section 3.b) - Note that this requires to transform a 1-dim result to a 2-dim results array by means of a adequately dimensioned tmp array.
Furthermore I simplified the formula building to avoid repeated rng.Address insertions just to show another way of doing it (see section 2.).
Sub GetLastName()
'0. Set this to the relevant sheet
Dim ws As Worksheet: Set ws = Sheet1
With ws
'1. Define data range
'1. a) Find last row in col G
Dim lRow As Long
lRow = .Range("G" & .Rows.count).End(xlUp).Row
'1. b) Provide for empty data set ' << Added to avoid title row evaluation
If lRow = 1 Then lRow = 2
'1. c) Set your range
Dim rng As Range: Set rng = .Range("G2:G" & lRow)
'2. Define formula string parts ' << Modified for better readibility
Dim FormulaParts()
FormulaParts = Array("INDEX(IFERROR(MID(", _
",SEARCH("" "",", _
",1),LEN(", _
")-SEARCH("" "",", _
",1)+1),""""),)")
'3. Assign last names to 2-dim array results
'3. a) Get all the last names from the range and store them
Dim results
results = Evaluate(Join(FormulaParts, rng.Address))
End With
'3.b) Provide for single results '<< Added to avoid Error 9 Subscript o/Rng
If UBound(results) = 1 Then '<< Force single element into 2-dim array
Dim tmp(1 To 1, 1 To 1)
tmp(1, 1) = results(1)
results = tmp
End If
'h) Display in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print ">"; results(i, 1)
Next i
'i) Write last names to target '<< Added to demonstrate writing back
ws.Range("H2").Resize(UBound(results), 1) = results
End Sub
I'm looking for a way to create an array in which it finds the average for columns E, F, G and H and then stores the average in an array. The only issue is the amount of rows in each column varies for each file I will run this array on (all the columns have the same amount of rows though) and so I pressure it'll be a dynamic array, and I also want the averaging to start from the second row as I have titles in the first row. If anyone knows how to do this the help would be much appreciated as I'm utterly confused.
As far as I know, empty cells doesn't count. So there is no need to define lastrow. Try this:
Sub AvToArray()
Dim rng As Range
Dim col As Range
Dim arrAv()
Dim i As Long
Set rng = Range("E:H")
ReDim arrAv(rng.Columns.Count)
For Each col In rng.Columns
arrAv(i) = WorksheetFunction.Average(col)
i = i + 1
Next col
End Sub
You can use the WorksheetFunction method for Average().
From what I understood from your question, you wanted the averages to be stored inside an array, so here you go..
Public Function lastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1)
With ws
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
Sub test()
Dim ws As Worksheet, aveArr(4) As Double
Set ws = ThisWorkbook.Worksheets(1)
'You said that you wanted to store the values to be inside an array...
With WorksheetFunction
aveArr(0) = .Average(ws.Range("E2:E" & lastRow(ws, "E")))
aveArr(1) = .Average(ws.Range("F2:E" & lastRow(ws, "F")))
aveArr(2) = .Average(ws.Range("G2:E" & lastRow(ws, "G")))
aveArr(3) = .Average(ws.Range("H2:E" & lastRow(ws, "H")))
End With
MsgBox aveArr(0) & vbNewLine & _
aveArr(1) & vbNewLine & _
aveArr(2) & vbNewLine & _
aveArr(3)
End Sub
My (very similar) solution to the others posted here:
Sub AverageArray()
Dim myarray As Variant, sht As Worksheet, lastrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "E").End(xlUp).Row 'or F, G, H, etc.
myarray = Array(Application.Average(Range("E2:E" & lastrow)), _
Application.Average(Range("F2:F" & lastrow)), _
Application.Average(Range("G2:G" & lastrow)), _
Application.Average(Range("H2:H" & lastrow)))
Debug.Print myarray(0)
Debug.Print myarray(1)
Debug.Print myarray(2)
Debug.Print myarray(3)
End Sub
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.
I want to select a array of sheets using the Sheets(Array()) method.
The sheets I want to select are named in the cells of my workheet Printlist.
The sheetnames are listed form column D to K.
Not all cells are filled so if I use the folowing function it errors on the rows with blank cells. How can I avoid this error:
This is what the sheet looks like:
And this is the code
Sub PDF_maken()
Dim ws As Worksheet
Dim LR As Long
Dim r As Range
Dim Mypath As String
Dim strarray As String
Set ws = ActiveWorkbook.Worksheets("Printlijst")
LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
For Each r In ws.Range("B20:B20").Cells
If Not IsEmpty("B" & r.Row) Then
Mypath = ws.Range("B" & r.Row).Text
colCheck = 4
Do Until Cells(r.Row, colCheck) = ""
strarray = strarray & IIf(colCheck > 4, ",") & """" & Cells(r.Row, colCheck).Value & """"
colCheck = colCheck + 1
Loop
ActiveWorkbook.Sheets(strarray).Select
ActiveWorkbook.SelectedSheets.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Mypath & ws.Range("C" & r.Row).Text & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Next r
End Sub
You can use a regular array rather than the Array() function to create the array. Then you can loop through the cells that contains sheet names and only add them if they're not blank. Here's an example.
Sub PDF_maken()
Dim ws As Worksheet
Dim lLastRow As Long
Dim rMap As Range
Dim sPath As String
Dim aSheets() As String
Dim lShCnt As Long
Dim rSh As Range
Set ws = ActiveWorkbook.Worksheets("Printlist")
lLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For Each rMap In ws.Range("B2:B" & lLastRow).Cells
'Make sure there's a path
If Not IsEmpty(rMap.Value) Then
sPath = ws.Range("B" & rMap.Row).Text
're-dimension an array to hold all the sheet names
ReDim aSheets(1 To Application.WorksheetFunction.CountA(rMap.Offset(, 2).Resize(1, 8)))
'reset the counter
lShCnt = 0
'loop through all the cells that might have a sheet name
'and add them to the array
For Each rSh In rMap.Offset(, 2).Resize(1, 8).Cells
If Not IsEmpty(rSh.Value) Then
lShCnt = lShCnt + 1
aSheets(lShCnt) = rSh.Text
End If
Next rSh
ActiveWorkbook.Sheets(aSheets).Select
ActiveSheet.ExportAsFixedFormat xlTypePDF, sPath & rMap.Offset(0, 1).Text & ".pdf"
End If
Next rMap
ws.Select
End Sub
If you get Error 9: Subscript Out of Range there are three things to check:
The first one is that you spelled a sheet name wrong. Make sure there are no spaces or other funny business that makes it look like you have a good sheet name and you don't.
Next, make sure you qualify all of your references back to the workbook level. Depending on where your code is, unqualified references can point to different places. Don't ever use Sheets(). Always use ThisWorkbook.Sheets() or some other workbook reference. That will make sure you're not trying to access a sheet in a workbook that you didn't intend to.
Finally, you can get that error if you pass numbers to Sheets because your sheet names are numbers. Or rather they look like numbers, but they're really text. sheets(array(1234,4567)).select is different than sheets(array("1234","4567")).select. You have to pass strings to Sheets or you'll get that error. Kind of. You can pass numbers, but it will Select the sheets based on their index numbers rather than their names. That's why you have to be extra careful when your sheet names look like numbers.
Do a similar loop,
something like
colCheck=4
do until cells(r.row,colCheck)=""
strArray=strarray & iif(colCheck>4,",","") & cells(r.row,colCheck).value
colCheck=colCheck+1
loop
then you'll get something like a,b,c I've not tested this, so may need some tweaking. I'll revisit in a moment.