How to get clipboard into a 2D array (excel vba) - arrays

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

Related

Subscript out of range when trying to loop through array to read values

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.

Copy a given column of a VBA 2D array to a worksheet column

I'm importing a table from a Tab-separated text file. I'm only interested in certain columns, so this is what I'm trying to do:
No problem: Read entire file into one long string
No problem: Split long string into rows, along vbCrlf
No problem: split each row into cells, along vbTab. Put those values into a 2d array
Problem: Sheets("Sheet2").Range("A:A") = Matrix (only a selected column)
I need help to find the syntax how to address e.g. the 5th column of the matrix, all rows.
Did I make myself clear?
Open Filename For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
Debug.Print strData(1)
Dim Matrix() As String
Dim Fields() As String
Fields = Split(strData(0), vbTab)
Dim Rader As Long
Dim Kolumner As Long
ReDim Matrix(UBound(strData), UBound(Fields))
For Rader = 0 To UBound(strData)
Fields() = Split(strData(Rader), vbTab)
For Kolumner = 0 To UBound(Fields)
Matrix(Rader, Kolumner) = Fields(Kolumner)
Next Kolumner
Next Rader
Sheets("Sheet2").Range("A:A") = Matrix 'that gets me the first column. How to pick another matrix column?
Write Only Specified Columns From Array to Worksheet
Adjust the constants including the workbook and DataColumns.
The first Sub writes the columns specified in DataColumns to a worksheet.
The second Sub writes all columns to the worksheet.
The rest is being called.
ByRef (not necessary) is used to point out that values
are being modified in the referred variable.
The Code
Option Explicit
Sub writeColumns()
' Text
Const FilePath As String = "G:\Data\Baby Names\yob2018.txt"
Const LineDelimiter As String = vbCrLf
Const FieldDelimiter As String = ","
' Worksheet
Const wsId As Variant = "Sheet1"
Const FirstCell As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim DataColumns() As Variant: DataColumns = Array(3, 1)
' Write from Text File to Data Array.
Dim Data() As String
getTextToArray Data, FilePath, LineDelimiter, FieldDelimiter
' Write from Data Array to Columns Array.
Dim Cols() As Variant: Cols = getColumns(Data, DataColumns)
' Write from Columns Array to Columns Range.
writeWorksheet Cols, wb, wsId, FirstCell
End Sub
Sub writeAll()
' Text
Const FilePath As String = "G:\Data\Baby Names\yob2018.txt"
Const LineDelimiter As String = vbCrLf
Const FieldDelimiter As String = ","
' Worksheet
Const wsId As Variant = "Sheet1"
Const FirstCell As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook
' Write from Text File to Data Array.
Dim Data() As String
getTextToArray Data, FilePath, LineDelimiter, FieldDelimiter
' Write from Data Array to Data Range.
writeWorksheet Data, wb, wsId, FirstCell
End Sub
Sub getTextToArray(ByRef Data() As String, _
ByVal FilePath As String, _
Optional ByVal LineDelimiter As String = vbCrLf, _
Optional ByVal FieldDelimiter As String = " ")
' Write from Text File to Text Variable.
Dim Text As String: getText Text, FilePath
' Write from Text Variable to Lines Array.
Dim Lines() As String: getLines Lines, Text, LineDelimiter
' Split Lines Array to Data Array.
getFields Data, Lines, FieldDelimiter
End Sub
Sub getText(ByRef Text As String, _
ByVal TextFilePath As String)
Open TextFilePath For Binary As #1
Text = Space$(LOF(1)): Get #1, , Text
Close #1
End Sub
Sub getLines(ByRef Lines() As String, _
ByVal Text As String, _
Optional ByVal LineDelimiter As String = vbCrLf)
Lines = Split(Text, LineDelimiter)
removeLastEmptyLines Lines
End Sub
Sub removeLastEmptyLines(ByRef Lines() As String)
If UBound(Lines) = -1 Then Exit Sub
Dim c As Long, ub As Long: ub = UBound(Lines)
For c = ub To LBound(Lines) Step -1
If Lines(c) = Empty Then
ub = ub - 1: ReDim Preserve Lines(ub)
Else
Exit For
End If
Next c
End Sub
Sub getFields(ByRef Data() As String, _
Lines() As String, _
Optional ByVal FieldDelimiter As String = " ")
Dim Fields() As String: Fields = Split(Lines(0), FieldDelimiter)
Dim ubL As Long: ubL = UBound(Lines) + 1
Dim ubF As Long: ubF = UBound(Fields) + 1
ReDim Data(1 To ubL, 1 To ubF)
Dim r As Long, c As Long
For r = 1 To ubL
Fields = Split(Lines(r - 1), FieldDelimiter)
For c = 1 To ubF
Data(r, c) = Fields(c - 1)
Next c
Next r
End Sub
Function getColumns(Data() As String, _
DataColumns() As Variant) _
As Variant
Dim ubD As Long: ubD = UBound(Data)
Dim ubC As Long: ubC = UBound(DataColumns)
Dim Result As Variant: ReDim Result(1 To UBound(Data), 1 To ubC + 1)
Dim r As Long, c As Long
For r = 1 To ubD
For c = 0 To ubC
Result(r, c + 1) = Data(r, DataColumns(c))
Next c
Next r
getColumns = Result
End Function
Sub writeWorksheet(Data As Variant, WorkbookObject As Workbook, _
Optional ByVal WorksheetNameOrIndex As Variant = "Sheet1", _
Optional ByVal FirstCellAddress As String = "A1")
With WorkbookObject.Worksheets(WorksheetNameOrIndex).Range(FirstCellAddress)
.Resize(UBound(Data), UBound(Data, 2)).Value = Data
End With
End Sub

split cell on underlined words vba

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

Can't get valid filepaths read from a text file to word. Double quotes don't work. (Run-time error '5152' with InlineShapes)

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

New array dimension on break line

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

Resources