Is there a way to use the split function in vba to split the cells based on underlined words? How can the delimiter be set to an underline?
d = Trim(cell.Value2)
arr = Split(d, " ")
Here is one approach. A lot of error handling scope is there, but this will give you set you in right direction.
Put Test with e or any other char underlined in A1 to test.
Public Function getArray(rng As Range)
Dim arr()
Dim lCtr As Long
Dim strText As String
Dim strDelim As String
'/ Create a delim which is qunique, so you dont miss any data.
strDelim = "!!_<{>}##"
For lCtr = 1 To rng.Characters.Count
If rng.Characters(lCtr, 1).Font.Underline = XlUnderlineStyle.xlUnderlineStyleSingle Then
'/ Splits exluding the underlined char
strText = strText & strDelim
'/ Splits including the underlined char
'strText = strText & rng.Characters(lCtr, 1).Text & strDelim
Else
strText = strText & rng.Characters(lCtr, 1).Text
End If
Next
getArray = Split(strText, strDelim)
End Function
Sub test()
MsgBox getArray(Cells(1, 1))(0)
End Sub
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 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 need to replace 108 images in word. I wrote VBA code so that for each inline image read in the document, the image will be replace by a new image. The new image is specified by a array that has filepaths in each element. The array comes from a text file.
For some reason, my code won't work if I have my variable, strPath as
strPath = dataArray(i)
or
strPath = Chr(34) & dataArray(i) & Chr(34)
What does work is if I type in
dataArray(0) = "C:\IMGS\G.2.1\NZ_DWH_v_SIMAP_AR1_biovalbox1_1100-1400m_Apr20-May26.png"
The path in the textfile is
C:\IMGS\G.2.1\NZ_DWH_v_SIMAP_AR1_biovalbox1_1100-1400m_Apr20-May26.png
I have 108 lines in the textfile, each for the image that needs to be replaced.
I have displayed the path in a message box and it looks like the above, so I am not sure why I can't get file paths from an array. Can someone help me?
'1-loop thru all figs
'2-bring up box to select figure
'3-add figure
Dim intChoice As Integer
Dim strPath As String
Dim objPic As InlineShape
Dim intCount As Integer
'import text
Dim dataArray() As String
Dim i As Integer
Dim g As Integer
strFileName = "C:\Users\cturner\Desktop\filesimgs_order.txt"
Open strFileName For Input As #1
dataArray = Split(Input$(LOF(1), #1), vbLf)
Close #1
g = 0
intCount = ActiveDocument.InlineShapes.Count
'loop through inline shapes
For i = 0 To intCount
strPath = Chr(34) & dataArray(i) & Chr(34)
MsgBox (TypeName(strPath))
g = g + 1
'check if valid filepath
'Debug.Print FileExists(strPath)
MsgBox strPath
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(g).Type = wdInlineShapePicture Then
Set objPic = ActiveDocument.InlineShapes.Item(g)
objPic.Select
'insert the image
Selection.InlineShapes.AddPicture FileName:= strPath, _
LinkToFile:=False, SaveWithDocument:=True
End If
Next i
End Sub
Suprise Suprise, I forgot to trim the carriage return vbCr. After I got that out, code works fine and I am able to replace my buttload of images.
Part 1. I checked my string if it has carriage return. Main problem is that I didn't clean my string, and thus putting it into a function made vba throw the error message (no bueno). If you have it, UBound should = 1
For i = 0 To 2
strPath = dataArray(i)
checkcr = Split(strPath, vbCr)
firstIndex = LBound(checkcr)
lastIndex = UBound(checkcr)
MsgBox (firstIndex)
MsgBox (lastIndex)
MsgBox checkcr(lastIndex)
newstrPath = Replace(strPath, vbCr, "")
MsgBox newstrPath
Next i
Part 2. Corrected Code + bonus. Bouns: some code to check if the file exists (from here )
fix:
newstrPath = Replace(strPath, vbCr, "")
Updated Code:
Sub replacefigs()
' replacefigs Macro
' To replace old figures with new figures (updated disclosure)
'0-get full file paths from textfile
'1-loop thru all figs
'2-bring up box to select figure
'3-add figure
Dim intChoice As Integer
Dim strPath As String
Dim objPic As InlineShape
Dim intCount As Integer
'import text
Dim dataArray() As String
Dim i As Integer
Dim g As Integer
strFileName = "C:\Users\cturner\Desktop\filesimgs_order.txt"
Open strFileName For Input As #1
dataArray = Split(Input$(LOF(1), #1), vbLf)
Close #1
g = 0
intCount = ActiveDocument.InlineShapes.Count
'loop through inline shapes
For i = 0 To intCount
strPath = dataArray(i)
'Get rid of carriage returns
newstrPath = Replace(strPath, vbCr, "")
g = g + 1
'to check if file exists
'Debug.Print FileExists(newstrPath)
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(g).Type = _
wdInlineShapePicture Then
Set objPic = ActiveDocument.InlineShapes.Item(g)
objPic.Select
'insert the image
Selection.InlineShapes.AddPicture FileName:= _
newstrPath, LinkToFile:=False, _
SaveWithDocument:=True
End If
Next i
End Sub
I'm putting data from the clipboard into my array and splitting it by new lines. But I also need a second dimension splitted by tabs, but don't know how? The data in clipboard is supposed to have a fixed size, so the number of parts will be the same for each line.
What I have so far
Private Sub btnPaste_Click()
Dim Clipboard As MSForms.DataObject
Dim arrClip As Variant
Dim i As Long
Dim str As String
Dim msg As String
On Error GoTo ERRORHAND
Set Clipboard = New MSForms.DataObject
Clipboard.GetFromClipboard
str = Clipboard.GetText(1)
arrClip = Split(str, vbLf)
For i = LBound(arrClip) To UBound(arrClip)
msg = msg & arrClip(i) & vbLf
Next
MsgBox (msg)
Exit Sub
ERRORHAND:
If Err <> 0 Then Debug.Print Err.Description
End Sub
This gives me an array with new elements on each new line from clipboard, but I don't know how to add elements to a second dimension on each 'tab' found in clipboard?
Example of data in clipboard and how I want it to fill the array
Data in clipboard
Data00 Data10 Data20 Data30
Data01 Data11 Data21 Data31
Data02 Data12 Data22 Data32
Data03 Data13 Data23 Data33
etc...
Should be corresponding array element
Array(0,0) Array(1,0) Array(2,0) Array(3,0)
Array(0,1) Array(1,1) Array(2,1) Array(3,1)
Array(0,2) Array(1,2) Array(2,2) Array(3,2)
Array(0,3) Array(1,3) Array(2,3) Array(3,3)
etc...
This is your code with some adds (hope it helps)
Sub btnPaste_Click()
Dim Clipboard As MSForms.DataObject
Dim arrClip As Variant
Dim i As Long
Dim str As String
Dim msg As String
Dim arrClip2 As Variant
Dim arrClipBid() As Variant
Dim ii As Integer
'On Error GoTo ERRORHAND
Set Clipboard = New MSForms.DataObject
Clipboard.GetFromClipboard
str = Clipboard.GetText(1)
arrClip = Split(str, vbLf)
ReDim arrClipBid(LBound(arrClip) To UBound(arrClip), 0 To 0)
For i = LBound(arrClip) To UBound(arrClip)
arrClip2 = Split(arrClip(i), Chr(9))
If MaxLen < UBound(arrClip2) Then
MaxLen = UBound(arrClip2)
ReDim Preserve arrClipBid(LBound(arrClip) To UBound(arrClip), 0 To MaxLen)
End If
For ii = LBound(arrClip2) To UBound(arrClip2)
arrClipBid(i, ii) = arrClip2(ii)
msg = msg & "(" & i & ", " & ii & ")" & arrClip2(ii)
Next ii
msg = msg & vbLf
Next
MsgBox (msg)
Exit Sub
ERRORHAND:
If Err <> 0 Then Debug.Print Err.Description
End Sub
I'm very new to Excel VBA and I want to get text from clipboard into a 2D array, with first delimiter vbNewLine and second delimiter space. How do I create a 2D array with unknown size? Can I split an array, like below where I fail?
Sub CommandButton1_Click()
Dim DataObj As MsForms.DataObject
Set DataObj = New MsForms.DataObject
Dim strArray() As String
On Error GoTo ERRROR
'~~> Get data from the clipboard.
DataObj.GetFromClipboard
'~~> Get clipboard contents
myString = DataObj.GetText(1)
'~~> Split into string, delimiter vbNewLine
strArray = Split(myString, vbNewLine)
Here is here I fail
'~~> Split each strArray and store in strArray2, delimiter " ".
Dim strArray2() As String
For ii = LBound(strArray2) To UBound(strArray2)
strArray2(ii) = Split(strArray(ii))
Next ii
Exit Sub
ERRROR:
If Err <> 0 Then
'Handel error
End If
End Sub
You are doing it the wrong way.
Is this what you are trying? (UNTESTED)
Sub CommandButton1_Click()
Dim DataObj As MsForms.DataObject
Dim strArray, strArray2
Dim i As Long, j As Long
Dim myString As String
On Error GoTo ERRROR
Set DataObj = New MsForms.DataObject
'~~> Get data from the clipboard.
DataObj.GetFromClipboard
'~~> Get clipboard contents
myString = DataObj.GetText(1)
'~~> Split myString, delimiter vbNewLine
strArray = Split(myString, vbNewLine)
'~~> Split each strArray and store in strArray2, delimiter " ".
For i = LBound(strArray) To UBound(strArray)
strArray2 = Split(strArray(i))
For j = LBound(strArray2) To UBound(strArray2)
Debug.Print strArray2(j)
Next j
Next i
Exit Sub
ERRROR:
If Err <> 0 Then Debug.Print Err.Description
End Sub