I'm a VBA newbie and I'm trying to make an array from some text (i.e. the names of the worksheets) I have listed out in a column ("B") - so I can save all my worksheets as a single PDF file, but with the option of adding or removing worksheets over time (as in, rewriting them under wksAllSheets over and over again).
So far I have:
Public Sub saveAsPDF()
Application.ScreenUpdating = False
Call print_reports 'a sub I created with the printing layours
Dim wksAllSheets As Variant
Dim wksSheet1 As Worksheet
Dim strFilename, strName As String, strFilepath As String
Set wksSheet1 = ThisWorkbook.Sheets("SheetCOVER") 'reference ws
wksAllSheets = Array("SheetCOVER", "Sheet1", "Sheet2", "Sheet3", "Sheet4", _
"Sheet5", _
"Sheet6", "Sheet7", "Sheet8")
ThisWorkbook.Sheets(wksAllSheets).Select
wksSheet1.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
wksSheet1.Select
Sheets("Home").Select
End Sub
Any help would be extremely appreciated!!
Here is how to create an array from a table starting from "B1"
Dim n_rows as Long, n_cols as Long
Dim r as Range
Set r = Range("B1")
' Count non-empty cells
n_rows = Range(r, r.End(xlDown)).Rows.Count
n_cols = 1 ' Assume table has one column.
' Set the range variable 'r' to the entire table of cells
Set r = r.Resize(n_rows, n_cols)
Dim vals() as Variant ' This is the dynamic array spec
vals = r.Value ' Here you fill the array from the cells
Dim i as Long
For i=1 to n_rows
Debug.Pring vals(i,1) 'You access the array with (i,j): i=row, j=column
Next i
to dynamically build the list of sheets you can use the sheets collection
For Each ws In Sheets
Select Case ws.Name
Case "Home","COVER" ' exclude these sheets
Case Else 'include all others
wksAllSheets = wksAllSheets & IIf(wksAllSheets = "", "", ",") & ws.Name
End Select
Next
wksAllSheets = Split(wksAllSheets, ",")
to build the list from a specific column in a sheet of your workbook
wksallsheets=application.transpose(sheets("listpdf").range("B1:B" & sheets("listpdf").cells(rows.count,"B").end(xlup).row))
Related
I have a string of predefined worksheets, that I need to run specific code for. I get a compile error.
The code is set up to copy data from one sheet to another.
How do I do the same for multiple sheets?
When I step through the code sht is showing the MHP60,MHP61,MHP62 and not just MHP60.
I get a subscript out of range error.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim SheetNames() As String
Dim SheetNames2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60, MHP61, MHP62 Trial Balance Values
Dim i, lastcol As Long
Dim tabNames, cell As Range
Dim tabName As String
Dim sht As Variant
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior")
Set wb1 = ActiveWorkbook 'Revenue & Expenditure Summary Workbook
'*****************************Open CYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Load Column Header Strings & Copy Data
For Each sht In SheetNames
lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets(sht).Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Next sht
MsgBox "CYTD Report Creation Complete", vbOKOnly
Application.ScreenUpdating = True
End Sub
Split by what?
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
Split by comma? Then use the following instead:
SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")
Alternative
Dim SheetNames() As Variant ' needs to be Variant to work with Array()
SheetNames = Array("MHP60", "MHP61", "MHP62")
This should be quicker as your macro does not need to split the string and has it as array directly.
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 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 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 have this:
column A
row1: str1;str2;str3
row2: str4;str5;str6
row3: str7;str8;str9
....................
rown: strn;strn;strn
The code below finds ";" character into the column A:
Range("A:A").Find(What:=";", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
I want to put all rows (from column A, containing semicolon character) into an array. I tried to use SET, like this:
dim r as Variant
Set r = Range("A:A").Find(What:=rngsearch, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=_
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,MatchCase:=False _
, SearchFormat:=False).Activate
...but doesn't work. It's run-time error '13', type mismatch
I need this array (containing all the cells with semicolon) because I want to extract the strings (from str1 to strn) and separate them in different rows.
Can anyone help me? Maybe someone has another idea how I can do this?
There are probably more efficient ways to do this, I would personally prefer to avoid referring to an entire column, but this should hopefully do what you are expecting:
Sub test()
Dim ws As Worksheet
Dim rng As Range
Dim cel As Range
Dim strTmp As String
Dim arrFinal As Variant
Set ws = Sheets("Sheet1")
Set rng = ws.Range("A:A")
' Loop through all cells in column A
For Each cel In rng.Cells
' Is there a semicolon character in the cell?
If InStr(1, cel.Value, ";") > 0 Then
' Add the cell value to strTmp and add a _
semicolon at the end to separate this _
row from the next row
strTmp = strTmp & cel.Value & ";"
End If
Next cel
' Split strTmp into an array
arrFinal = Split(strTmp, ";")
End Sub
The end result Is an array called arrFinal of all strings between the semicolon characters
I was referring to something like this:
Sub GetSemicolonData()
Dim rngCell As Excel.Range
Dim asValues() As String
Dim lngCount As Long
Dim x As Long
With Range("A1").CurrentRegion.Columns(1)
.AutoFilter field:=1, Criteria1:="*;*"
lngCount = .SpecialCells(xlCellTypeVisible).Count
If lngCount > 1 Then
x = 1
' exclude header row
ReDim asValues(1 To lngCount - 1)
For Each rngCell In .SpecialCells(xlCellTypeVisible)
If rngCell.Row > 1 Then
' load value into array
asValues(x) = rngCell.Value
x = x + 1
End If
Next rngCell
End If
End With
End Sub
You could also use a variation of Dave's approach that loads all the data into an array and processes that - it should be faster than cell by cell reads.