I have a sheet with arrays with data that I want to save in a dictionary. The column space between each array is constant and the tables are similar size. I have names on top of each array (first one in cell J3) that should be the key and the data should be the item. How can I create a loop that saves all arrays and stops when the selected range is empty?
Sub Dictionary()
Dim dictionary() As Dictionary
Dim nCol As Integer, i As Integer
nCol = 13
Sheets("Sheet1").Activate
Range(Cells(27, 11), Cells(36, 21)).Activate
For i = 1 To nCol
' dictionary(i) = Selection.Value
Selection.Offset(RowOffset:=0, ColumnOffset:=nCol).Select
Next i
End Sub
Thank you
Please, test the next code. It needs a reference to 'Microsoft Scripting Runtime':
Sub RangesIndictionary()
Dim sh As Worksheet, dict As New scripting.dictionary, nCol As Long
Dim i As Long, rngInit As Range, rngKey As Range, keyName As String
Set sh = Sheets("Sheet1")
nCol = 13
Set rngKey = sh.Range("J3")
keyName = rngKey.Value
Set rngInit = sh.Range(sh.cells(27, 11), sh.cells(36, 21))
Do While keyName <> ""
dict.Add keyName, rngInit
Set rngKey = rngKey.Offset(0, nCol)
keyName = rngKey.Value
Set rngInit = rngInit.Offset(0, nCol)
Loop
Debug.Print dict.count & " ranges have been placed in the dictionary"
Debug.Print "The first range is " & dict(sh.Range("J3").Value).Address
End Sub
It may work using Late binding, but it is better to use the reference and benefit of the intellisense suggestions.
If it is possible that the name to be the same for two such ranges, the code should preliminary check if the key exists. And you must tell us how to be treated such a situation.
In order to automatically add the necessary reference, please firstly run the next code:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
If err.Number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "The reference already exists...": Exit Sub
Else
On Error GoTo 0
MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
End If
End Sub
It will remain only if you save the working workbook...
Related
I am trying to create a subroutine that will take a collection of a bunch of strings, step through it, and check for the existence of a named range or formula that has that string as it's name. Trying it with just one item first:
Dim colCritNames As New Collection
colCritNames.Add "Version" 'the name of a named formula
For i = 1 To colCritNames.Count
nm = CStr(colCritNames(i).Name)
nmchk = Check_UW_For_Name(nm)
If Not nmchk Then Call Fail("Critical Name") 'prints a msgbox with the error type so I know what happened
Next i
'...code for if all the names are there...
Function Check_UW_For_Name(find_name As String) As Boolean
Dim wb As Workbook
Set wb = UserFileBook 'global ref to the workbook to check
On Error Goto Fail
Check_UW_For_Name = CBool(Len(wb.Names(find_name).Name) <> 0)
On Error GoTo 0
End Function
Thats edited from the full thing. Check_UW_For_Name was working fine when I just called it with "Version" as the argument Check_UW_For_Name("Version"); it found it in USerFIleBook, and when I called it with "Nope", since there is no Nope name it went to my error handler. But when I try to use a collection to store the names I want to look for I keep getting 'ByRef argument mismatch'. I tried just nm = colCritNames(i) and nm=colCritNames(i).Name, I tried having find_name be Variant and adding a ByVal, and I originally tried having nm be a Name, having Check_UW_For_Name(find_name as Name) and using a for each (for each nm in colCritNames...) and none of it has worked.
How could I set a collection of names and step through it to see if there's a named range/formula that matches in the relevant workbook? Or is there a better way to do this? (I need the collection in other places too)
I don't quite understand what your plan is with a collection, but this will add any cell with the specified string in, as well as any ranges. What you're doing once they've been identified (added to collection) is not clear to me, but hopefully this makes sense and gets you going.
Sub RunForEachString()
Const yourStrings = "foo,bar,hope,this,works"
Dim stringsAsArray() As String
stringsAsArray = Split(yourStrings, ",")
Dim i As Long
For i = LBound(stringsAsArray) To UBound(stringsAsArray)
Call findAllNamesFormulas(stringsAsArray(i), ThisWorkbook)
Next i
End Sub
Private Sub findAllNamesFormulas(theText As String, theWorkbook As Workbook)
Dim ws As Worksheet, n As Name, aCell As Range
Dim aCollection As New Collection
For Each ws In ThisWorkbook.Worksheets
For Each aCell In ws.UsedRange.Cells
If InStr(1, aCell.Formula, theText, vbTextCompare) > 0 Then
aCollection.Add (aCell)
End If
Next aCell
Next ws
For Each n In ThisWorkbook.Names
If InStr(1, n.Name, theText, vbTextCompare) > 0 Then
aCollection.Add (n)
End If
Next n
'not sure what you plan to do after collection?
Debug.Print aCollection.Count
End Sub
This works for me:
Sub Tester()
Dim colCritNames As New Collection, nm, wb As Workbook, msg As String
colCritNames.Add "Version"
colCritNames.Add "NotThere"
colCritNames.Add "AlsoNotThere"
Set wb = ThisWorkbook 'for example
For Each nm In colCritNames
If Not Check_UW_For_Name(wb, CStr(nm)) Then
msg = msg & vbLf & " - " & nm
End If
Next nm
If Len(msg) > 0 Then
MsgBox "One or more required names are missing:" & msg, _
vbExclamation, "Oops"
Exit Sub
End If
'proceed if OK...
End Sub
'check for a defined Name `find_name` in workbook `wb`
' prefer wb as parameter over using a Global....
Function Check_UW_For_Name(wb As Workbook, find_name As String) As Boolean
On Error Resume Next
Check_UW_For_Name = (wb.Names(find_name).Name = find_name)
End Function
You could create a collection of all named ranges in the workbook like this:
Private Sub NamedRangesDemo()
Dim NamedRanges As New Collection, NamedRange As Variant
For Each NamedRange In ThisWorkbook.Names
NamedRanges.Add NamedRange.Name
Next NamedRange
End Sub
And then compare the whatever strings you want to the NamedRanges collection.
By the way, this question is somewhat similar to yours.
For reasons unbeknownst to me, I am getting an error on a dynamic array with in a macro. It keeps saying "Subscript out of range". But - here's the kicker - if I run the same macro again after the error is displayed, then it would not complain. Here is the piece of code that I have
Both the arrays (arrTemp and arrPBIs) are declared as in a separate module along with the rest of the variables:
Public arrPBIs() As Variant
Public arrTemp() As Variant
arrTemp = Worksheets("Prioritized PBIs Only").Range("B2:B6").Value
ReDim arrPBIs(UBound(arrTemp))
For iRw = 1 To UBound(arrTemp)
If arrTemp(iRw, 1) <> "" Then
x = x + 1
arrPBIs(x) = arrTemp(iRw, 1)
End If
Next iRw
ReDim Preserve arrPBIs(x)
Where am I going wrong? Thanks in advance for your assistance.
As a more general answer to using arrays in VBA and getting arrays from Excel into VBA the following code may be helpful. You need to have the locals and immediate windows open when you run the code.
Option Explicit
Sub ArrayDemo()
Dim VBAArray As Variant
Dim ExcelArray As Variant
Dim ExcelArray2D As Variant
Dim TransposedExcelArray As Variant
' Excel is setup to have 10 to 50 step 10 in A1:A5
' and 100 to 500 step 100 in B1:B5
VBAArray = Array(1, 2, 3, 4, 5)
ExcelArray = ActiveSheet.Range("A1:A5").Value
ExcelArray2D = ActiveSheet.Range("A1:B5").Value
TransposedExcelArray = WorksheetFunction.Transpose(ActiveSheet.Range("A1:A5").Value)
On Error Resume Next
Debug.Print ExcelArray(1) ' gives an error
Debug.Print "Error was", Err.Number, Err.Description
Err.Clear
On Error Resume Next
Debug.Print TransposedExcelArray(1) ' works fine
Debug.Print "Error was", Err.Number, Err.Description
Dim myItem As Variant
For Each myItem In ExcelArray2D
Debug.Print myItem
Next
Stop ' Look in the locals window for how the arrays are setup
End Sub
I'm trying to write a VBA macro that will read through a text document and place specific words into columns. UPDATE: Here's a sample of the file, apparently it's XML, so at least I learned something new today. So i guess what I need is a program to shed the XML parts, and place just the text into columns.
<Alarm>
<ID>1002</ID>
<Type>Fault</Type>
<Message>Bad Brake</Message>
<Tagname>error.e2</Tagname>
</Alarm>
<Alarm>
<ID>1004</ID>
<Type>Fault</Type>
<Message>No Motion</Message>
<Tagname>error.e4</Tagname>
</Alarm>
<Alarm>
<ID>1005</ID>
<Type>Fault</Type>
<Message>Upper safety door open</Message>
<Tagname>error.e5</Tagname>
</Alarm>
Ultimately, I'm trying to put the 4 digit error codes in column A (i.e. 1002, 1004...), and the error message in column B (i.e. Bad Brake, No motion....). I'll paste what I have so far, I tried coding it for just one pair of data to start. I'm stuck trying to get the error message into column B. The error messages all start in the same position on each line, but I can't figure out how to stop copying the text, since each error message is a different length of characters. Any ideas?
(P.S. - I apologize if the code is terrible, I've been interning as an electrical engineer, so my programming has gotten rather rusty.)
Private Sub CommandButton1_Click()
Dim myFile As String, textLine As String, ID As Integer, error_msg As Integer
myFile = "C:\Users\scholtmn\Documents\Projects\Borg_Warner_txt_file\BW_fault_codes.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textLine
Text = Text & textLine
Loop
Close #1
ID = InStr(Text, "<ID>")
error_msg = InStr(Text, "<Message>")
Range("A1").Value = Mid(Text, ID + 4, 4)
Range("B1").Value = Mid(Text, error_msg + 9, (InStr(Text, " <") - 31))
End Sub
Please, try the next code:
Sub ExtractErrorsDefinition()
'it needs a reference to 'Microsoft XML, v6.0'
Dim XMLFileName As String, oXMLFile As New MSXML2.DOMDocument60, sh As Worksheet
Dim N As MSXML2.IXMLDOMNode, i As Long, arr
Set sh = ActiveSheet 'use here the necessary sheet
XMLFileName = "the full text file path" '"C:\Utile\Teste Corel\XMLtext.txt"
oXMLFile.Load (XMLFileName)
ReDim arr(1 To oXMLFile.SelectNodes("AlarmDictionary/Alarm").length, 1 To 2): i = 1
For Each N In oXMLFile.SelectNodes("AlarmDictionary/Alarm")
arr(i, 1) = N.SelectSingleNode("ID").Text: arr(i, 1) = N.SelectSingleNode("Message").Text: i = i + 1
Next
sh.Range("A2").Resize(UBound(arr), 2).value = arr
End Sub
It may work using late binding, but it is better to have the intellisense suggestion, especially when not very well skilled in working with XML.
If looks complicated to add such a reference, I can add a piece of code to automatically add it.
Please, run the next code to automatically add the necessary reference. Save your workbook and run the first code after:
Sub addXMLRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\msxml6.dll"
End Sub
It looks like the txt file you are using is actually an xml file. If you changed the format, this piece of code I slightly adjusted from here should work fine.
Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFilePicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select an XML File"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row ' last used row, column A
xFile = xStrPath
Set xmlWb = Workbooks.OpenXML(xFile)
If first Then
Set r = xmlWb.Sheets(1).UsedRange ' with header
Else
xmlWb.Sheets(1).Activate
Set r = ActiveSheet.UsedRange
Set r = Range(Cells(3, 1), Cells(r.Rows.Count, r.Columns.Count))
End If
r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
xmlWb.Close False
first = False
End Sub
I think you'll find this task a lot easier if you take advantage of the fact it is in XML format. You can find more information about working with XML in VBA here.
As Ben Mega already stated: you have an XML-File - why not use XML-functionality.
Add "Microsoft XML, v6.0" to your project references - then you can use this code
Public Sub insertTextFromXML()
Dim objXML As MSXML2.DOMDocument60
Set objXML = New MSXML2.DOMDocument60
If Not objXML.Load("T:\Stackoverflow\Test.xml") Then
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If
Dim nAlarm As MSXML2.IXMLDOMNode
'loop through all alarms and output ID plus message
For Each nAlarm In objXML.SelectNodes("AlarmDictionary/Alarm")
With nAlarm
Debug.Print .SelectSingleNode("ID").Text, .SelectSingleNode("Message").Text
End With
Next
'Filter for ID 1004
Set nAlarm = objXML.SelectSingleNode("AlarmDictionary/Alarm[ID=1004]")
Debug.Print nAlarm.XML
End Sub
You can google for VBA XPath to find out how to access the various values.
I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete
I'm in need of help in understanding why I keep getting an "object required" error at Ln82. I thought you could store anything in a dictionary?
The workflow is:
Start the program
Create the dictionary of temporary items to loop through the input box
Use this dictionary later to store all the user input as ranges
Call a sub routine to open destination document(Mysupes)
Call a sub routine to open source excel wb(Alert)
Prompt user 12 times(via loop) to select ranges in source excel
Paste into destination word doc(at this point I don't care where, I just need to paste the damn thing)
Also please ignore any of the comments, it is just my scratch work where I've tried different avenues.
Sub AlertToSupes()
'Declarations
Dim MyAlert As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'Dim key As Variant
Dim v As Long
Dim r As Variant
Dim Mysupes As Document
'Mysupes.Visible = True
'Dim AlertToSupeData As Object
Application.ScreenUpdating = True
'Collection of objects to get from Alert doc and paste into Supes
'Dim colSupesData As Collection
'Set colSupesData = New Collection
' colSupesData.Add "Project team names"
' colSupesData.Add "Programming"
' colSupesData.Add "Date(today)"
' colSupesData.Add "Subject(Blind study name in Alert)"
' colSupesData.Add "LRW job#"
' colSupesData.Add "LOI"
' colSupesData.Add "Incidence"
' colSupesData.Add "Sample size"
' colSupesData.Add "Dates(select from Alert)"
' colSupesData.Add "Devices allowed"
' colSupesData.Add "Respondent qualifications(from Alert)"
' colSupesData.Add "Quotas"
'Dictionary of attributes(alternative to list)
dict.Add "Project team names", ""
dict.Add "Programming", ""
dict.Add "Date(today)", ""
dict.Add "Subject(Blind study name in Alert)", ""
dict.Add "LRW job#", ""
dict.Add "LOI", ""
dict.Add "Incidence", ""
dict.Add "Sample size", ""
dict.Add "Dates(select from Alert)", ""
dict.Add "Devices allowed", ""
dict.Add "Respondent qualifications(from Alert)", ""
dict.Add "Quotas", ""
'Open up the Supes
Call OpenSupes
'Open up the Alert file
MyAlert = Application.GetOpenFilename()
Workbooks.Open (MyAlert)
'Loop for subroutine
For Each key In dict.keys
Debug.Print (key)
Call Cpy(key)
dict.item = r.Value
Next key
End Sub
Sub Cpy(key As Variant)
'Loop that asks for user-defined input for every field of Supes
Dim r As Range, LR As Long
Dim Mysupes As Object
On Error Resume Next
Set r = Application.InputBox("Select the cell that contains " & key, Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
'LR = Cells(Rows.Count, r.Column).End(xlUp).Row
'Range(Cells(5, r.Column), Cells(LR, r.Column)).Copy Destination:=Cells(5, r.Column + 1)
r.Copy
With Mysupes
'AppWord.Documents.Add
AppWord.Selection.PasteExcelTable
Application.CutCopyMode = False
'Set MySupes = Nothing
End With
End Sub
Sub OpenSupes()
'Dim Mysupes As Object
Dim wordapp As Object
Dim Mysupes As FileDialog
Set wordapp = CreateObject("word.Application")
Set Mysupes = Application.FileDialog( _
FileDialogType:=msoFileDialogOpen)
Mysupes.Show
'Set Mysupes = wordapp.Documents.Open("\\10.1.11.169\LRW\Field (New)\01 Admin\02 Standard Documents\01 Supes\Supes Memo - Online Study.dotx")
wordapp.Visible = True
End Sub
There are numerous issues with the code.
1) Key one is that you are trying to use the Workbooks.Open method on a Word document. [Workbooks.Open][1] expects a workbook variable. So this:
Workbooks.Open (MyAlert)
isn't going to work with a Word doc.
You want Documents.Open but also need a Word application to use this with so you will need to create that application instance in the appropriate sub. You do it elsewhere with wordapp.Documents.Open
2) Use Option Explicit at the top of your code and declare all your variables. There are missing ones throughout.
3) Quit applications after opening them or eventually something will crash due to too many running instances.
4) Application.ScreenUpdating = True should be at the end of the sub to update the screen and only if you had Application.ScreenUpdating = False before that.
5) As #CindyMeister notes: You shouldn't need an On Error Resume Next around InputBox. You can test by setting the result to a variable and testing that.See Trouble with InputBoxes
6) And what #dbmitch said. A function conversion would be a logical choice.
The error you're reporting is generated inside your loop wen you try to assign r.Value to your dictionary
For Each key In dict.keys
Debug.Print (key)
Call Cpy(key)
dict.item = r.Value
Next key
You're assuming Cpy subroutine is sending the r cell back to your program,
but it's not - r is declared locally in your program as a variant and locally
inside Cpy as a Range.
You need to return r as a function value instead of a closed subroutine,
or you can make the r Range type variable a global so it can be seen by all your program