I use this code to copy 4 sheets to separate workbook. One of them - "1" have formulas inside, method below skips those formulas. Any ideas how to keep three workbook's as value only and one - "1" including the formulas? Part of code responsible for that action below. Thank you in advance.
Sub test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Fname As String, ws As Worksheet
Dim InitFileName As String, fileSaveName As String
Fname = Sheets("STRUCTURE").Range("A1").Value
Sheets(Array("STRUCTURE", "2", "3", "1")).Copy
For Each ws In ActiveWorkbook.Worksheets
With ws.UsedRange
.Value = .Value
End With
Next ws
With ActiveWorkbook
fileSaveName = "FILE LOCATION FOLDER " & Sheets("STRUCTURE").Cells(1, 1) & ".xlsx"
.SaveAs fileSaveName
.Close
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This is what is changing formulas to values:
With ws.UsedRange
.Value = .Value
End With
You have several options to skip the worksheet in question:
Skip the worksheet named 1.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "1" Then
With ws.UsedRange
.Value = .Value
End With
End If
Next
Only loop over the worksheets in question:
Dim sheetNamesToProcess As Variant
sheetNamesToProcess = Array("STRUCTURE", "2", "3")
Dim i As Long
For i = Lbound(sheetNamesToProcess) To Ubound(sheetNamesToProcess)
With ActiveWorkbook.Worksheets(sheetNamesToProcess(i)).UsedRange
.Value = .Value
End With
Next
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 have this little code that replaces the letters from a table like this (find the left string and replace it with the right string):
However it takes a great amount of time to do all the replacements in the sheets I have (just 2). Nearly 10 seconds. Is there a way to speed this up pls? Many thanks for taking the time!!
Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim ReplaceCount As Long
Set sht = Sheets("Sheet1")
Application.ScreenUpdating = False
'Create variable to point to your table
Set tbl = Worksheets("Sheet1").ListObjects("StringReplace")
'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 sht In ActiveWorkbook.Worksheets
If sht.Name <> tbl.Parent.Name Then
sht.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next sht
Next x
Application.ScreenUpdating = True
Replace Strings in Multiple Worksheets
The Code
Option Explicit
Sub replaceOddStrings()
Const WorksheetName As String = "Sheet1"
Const TableName As String = "StringReplace"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Data As Variant: Data = wb.Worksheets(WorksheetName) _
.ListObjects(TableName).DataBodyRange.Value
Dim ws As Worksheet
Dim i As Long
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
If ws.Name <> WorksheetName Then
For i = 1 To UBound(Data, 1)
ws.UsedRange.Replace Data(i, 1), Data(i, 2), xlPart, , False, _
False, False, False
Next i
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Strings replaced.", vbInformation, "Success"
End Sub
I am trying to create a looping variable that looks through a string for an array of strings and assigns them to a group if a match is found, however, I don't need it to be an exact match, just if the source string is LIKE the search string. Example code posted below:
Sub add_Categories()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("B1", Range("B65536").End(xlUp))
Application.DisplayAlerts = False
With wSheetStart
For Each rCell In rRange
If rCell Like "*Apple*" Then rCell.Offset(0, 2) = "Grocery"
If rCell Like "*Orange*" Then rCell.Offset(0, 2) = "Grocery
If rCell Like "*Mop*" Then rCell.Offset(0, 2) = "Kitchen"
If rCell Like "*Broom*" Then rCell.Offset(0, 2) = "Kitchen"
'If rCell Like "*Shirt*" Then rCell.Offset(0, 2) = "Clothing"
'If rCell Like "*Pants*" Then rCell.Offset(0, 2) = "Clothing"
Next rCell
End With
With wSheetStart
'.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
The example above only has two strings per category, but in reality I have hundreds and it would be much easier to enter them as an array than to have a line for each statement. Any help is much appreciated.
This is one way you can use an array and loop through it:
Sub add_Categories()
Dim rRange As Range, rCell As Range, wSheet As Worksheet, wSheetStart As Worksheet, X As Long, FindArr As Variant, FoundArr As Variant
FindArr = Array("Apple", "Orange", "Mop", "Broom", "Shirt", "Pants")
FoundArr = Array("Grocery", "Grocery", "Kitchen", "Kitchen", "Clothing", "Clothing")
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("B1", Range("B" & Rows.Count).End(xlUp))
Application.DisplayAlerts = False
With wSheetStart
For Each rCell In rRange
For X = LBound(FindArr) To UBound(FindArr)
If rCell Like "*" & FindArr(X) & "*" Then rCell.Offset(0, 2) = FoundArr(X)
Next
Next
End With
With wSheetStart
'.AutoFilterMode = False
.Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
Add what you need to FindArr and the corosponding output to FoundArr
Also note the change here: Set rRange = Range("B1", Range("B" & Rows.Count).End(xlUp)) use rows.count instead of hard coding a row number.
I have a code, that grabs data from a column of a file, and puts it into an array.
now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?
this is the code, and the array is at the end:
Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES
Remove the duplicates during the string construction by testing for prior existence with InStr function.
If Not IsEmpty(Cells(i, 1).Value) And _
Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
You should also remove the last trailing comma before splitting.
Next i
strSearch = Left(strSearch, Len(strSearch) - 1)
Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.
This worked for me:
Function removeDuplicates(ByVal myArray As Variant) As Variant
Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(myArray) To UBound(myArray)
d(myArray(i)) = 1
Next i
i = 0
For Each v In d.Keys()
ReDim Preserve outputArray(0 To i)
outputArray(i) = v
i = i + 1
Next v
removeDuplicates = outputArray
End Function
Hope it helps
Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then
strSearch = strSearch & "," & .Cells(i, 1).Value
End If
Next i
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)
Or even faster (as you won't have empty cells in the range after the RemoveDuplicates) :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
'NO MORE DUPLICATES and FASTER ARRAY FILL ;)
searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine.
You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.
Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object
set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
if dicUniques.exists(cells(i,1).value) = false then
dicUniques.add cells(i,1).value, cells(i,1).value
end if
End If
Next i
End With
s_wbk.Close
for each var in dicUniques.keys
strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")
That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first.
By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object.
Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.
edit: Corrected typo in the routine.
Unique Column To Array
Option Explicit
Sub removeDuplicates()
Const strFile = "...\Desktop\xl files min\src.xlsm"
Const SheetName As String = "Sheet1"
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim s_wbk As Workbook
Dim SourceArray, WorkArray, searchItem
Set s_wbk = Workbooks.Open(strFile)
SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
FirstRow, SourceColumn)
s_wbk.Close
If Not IsArray(SourceArray) Then Exit Sub
WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
searchItem = getUniqueArray(WorkArray)
End Sub
Function copyColumnToArray(SourceSheet As Worksheet, _
FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant
Dim rng As Range
Dim LastRowNumber As Long
Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
LookIn:=xlFormulas, Searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Function
Set rng = SourceSheet.Range(SourceSheet _
.Cells(FirstRowNumber, ColumnNumberLetter), rng)
If Not rng Is Nothing Then copyColumnToArray = rng
End Function
Function getUniqueArray(SourceArray As Variant, _
Optional Transpose65536 As Boolean = False) As Variant
' Either Late Binding ...
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' ... or Early Binding:
' VBE > Tools > References > Microsoft Scripting Runtime
'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
Dim i As Long
For i = LBound(SourceArray) To UBound(SourceArray)
If SourceArray(i) <> Empty Then
dict(SourceArray(i)) = Empty
End If
Next i
' Normal: Horizontal (Row)
If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
' Transposed: Vertical (Column)
If dict.Count <= 65536 Then _
getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
' Transpose only supports up to 65536 items (elements).
MsgBox "Source Array contains '" & dict.Count & "' unique values." _
& "Transpose only supports up to 65536 items (elements).", vbCritical, _
"Custom Error Message: Too Many Elements"
exitProcedure:
End Function
I have the following code which searches the sheets named 1 to 12 in the workbook, and creates two sheets if Sheets from 1 to 12 are found. It takes into account the error if the any of the sheets between 1 to 12 are not present. Everytime one or many sheets can be absent from 1 to 12. Is it possible for me to create another array or change the array contents which will only contain the numbers corresponding to the sheets which are present in the workbook so that I can use this modified array in all the other codes to be applied to those sheets. Kindly suggest a code with which a new modified array can be created of only the existing sheets among 1 to 12.
Sub add_sheets()
Dim MyArr, j As Long
Dim wsarray As Sheets
Dim ws As Worksheet
MyArr = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12")
For j = 0 To UBound(MyArr)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(MyArr(j))
On Error GoTo 0
If Not ws Is Nothing Then
ActiveWorkbook.Sheets.Add After:=ws, Count:=2
Sheets(ActiveSheet.Index - 2).Activate
Else
Err.Clear
End If
Next
End Sub
A dictionary is convenient way to keep the list of worksheets
Added benefits of having both sheet Indexes, sheet Names, and Exists Method
This code uses the suggestion in the comments in Sub SetWorksheets() without triggering errors:
Option Explicit 'Add reference to: Tools -> References -> Microsoft Scripting Runtime
Public Sub AddSheets()
Dim wsList As Dictionary
Dim activeWs As Worksheet, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set activeWs = wb.ActiveSheet
Set wsList = New Dictionary: 'wsList.CompareMode = BinaryCompare
SetWorksheets wsList
TestWorksheets wsList, "Initial Worksheets"
While wsList.Count < 12
Set ws = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
With ws
wsList.Add Key:=.Index, Item:=.Name
End With
Wend
TestWorksheets wsList, "Final Worksheets"
DelWorksheets
activeWs.Activate
Application.ScreenUpdating = True
End Sub
Public Sub SetWorksheets(ByRef wsLst As Dictionary, _
Optional ByRef wb As Workbook = Nothing)
Dim ws As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
For Each ws In wb.Worksheets
With ws
wsLst.Add Key:=.Index, Item:=.Name 'Or: d.Add Key:=.Name, Item:=.Index
End With
Next
End Sub
A note, as it may not be very obvious: SetWorksheets() is a Sub and not a Function because the first parameter is passed ByRef and this implies, among other things, that it will be changed inside the Sub. As a result the initial object sent to this sub will also be updated
To test it:
Public Sub TestWorksheets(ByRef wsLst As Dictionary, txt As String)
Dim itm As Variant, msg As String
msg = txt & ": " & vbCrLf & vbCrLf
For Each itm In wsLst
With itm
msg = msg & vbTab & itm & ": " & vbTab & wsLst.Item(itm) & vbCrLf
End With
Next
MsgBox msg & vbCrLf & "Sheet 5 exists: " & vbTab & wsLst.Exists(5)
End Sub
Public Sub DelWorksheets()
Dim itm As Worksheet
Application.DisplayAlerts = False
For Each itm In ThisWorkbook.Worksheets
If itm.Index > 3 Then itm.Delete
Next
Application.DisplayAlerts = True
End Sub
Result: