In Sheet1, cell A1 I have the following text: A-B-C-D-E-F
I need to loop through this text and I have written the following code that works fine:
dim w as worksheet
dim s as variant
dim p as integer
set w = Worksheets(1)
p = 0
For Each s In Split(w.Range("A1").Value, "-")
p = p + 1
MsgBox Split(w.Range("A1").Value, "-")(p - 1)
Next s
The above code pops up the Message box showing each of the letters one after the other, as expected.
BUT I am not happy with the repeating of Split(w.Range("A1").Value, "-"), declaring the array for the loop and once again for every occurrence within the loop.
So I have tried with:
MsgBox s.Value
but it throws an error about an object being requested.
Why can I not use the Value property given that "s" is a variant?
Split returns a string array which is separated into individual strings by the For Each, so you can just pass those to MsgBox as is.
So, rather than using s.Value, just use s on its own.
In other words:
dim w as Worksheet
dim s as Variant
set w = Worksheets(1)
For Each s In Split(w.Range("A1").Value, "-")
MsgBox s
Next
You can do this like this
dim w as worksheet
dim s as string
set w = Worksheets(1)
For Each s In Split(w.Range("A1").Value, "-")
MsgBox s
Next
When you assign any object to a variant then it behaves like the object assigned to it and has only those properties which are present in object. In your For Each split you assigned string to s and string variables return their value directly and not by objString.Value.
Related
Option Explicit
Public Sub consolidateList()
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
FillTableRows
End Sub
Private Sub FillTableRows()
'set up worksheet objects
Dim wkSheet As Worksheet
Dim wkBook As Workbook
Dim wkBookPath As String
Set wkBook = ThisWorkbook
wkBookPath = wkBook.Path
Set wkSheet = wkBook.Worksheets("Master")
'set up file system objects
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(wkBookPath)
Set oFiles = oFolder.Files
'set up loop
Dim checkBook As Excel.Workbook
Dim reportDict As Dictionary
Application.ScreenUpdating = False
'initial coordinates
Dim startRow As Long
Dim startColumn As Long
startColumn = 3
Dim i As Long 'tracks within the row of the sheet where information is being pulled from
Dim k As Long 'tracks the row where data is output on
Dim j As Long 'tracks within the row of the sheet where the data is output on
Dim Key As Variant
j = 1
k = wkSheet.Range("a65536").End(xlUp).Row + 1
Dim l As Long
'look t Set checkBook = Workbooks.Open(oFile.Path)hrough folder and then save it to temp memory
On Error GoTo debuger
For Each oFile In oFiles
startRow = 8
'is it not the master sheet? check for duplicate entries
'oFile.name is the name of the file being scanned
'is it an excel file?
If Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xls" Or Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xlsx" Then
Set checkBook = Workbooks.Open(oFile.Path)
For l = startRow To 600
If Not (IsEmpty(Cells(startRow, startColumn))) Then
'if it is, time do some calculations
Set reportDict = New Dictionary
'add items of the payment
For i = 0 To 33
If Not IsEmpty(Cells(startRow, startColumn + i)) Then
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
End If
Next i
For i = startRow To 0 Step -1
If Not IsEmpty(Cells(i, startColumn - 1)) Then
reportDict.Add "Consumer Name", Cells(i, startColumn - 1)
Exit For
End If
Next i
'key is added
For Each Key In reportDict
'wkSheet.Cells(k, j) = reportDict.Item(Key)
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
MsgBox (myInsert)
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
j = j + 1
Next Key
wkSheet.Cells(k, j) = wkSheet.Cells(k, 9) / 4
wkSheet.Cells(k, j + 1) = oFile.Name
'
k = k + 1
' Set reportDict = Nothing
j = 1
Else
l = l + 1
End If
startRow = startRow + 1
Next l
checkBook.Close
End If
' Exit For
Next oFile
Exit Sub
debuger:
MsgBox ("Error on: " & Err.Source & " in file " & oFile.Name & ", error is " & Err.Description)
End Sub
Sub DeleteTableRows(ByRef Table As ListObject)
On Error Resume Next
'~~> Clear Header Row `IF` it exists
Table.DataBodyRange.ClearContents
'~~> Delete all the other rows `IF `they exist
Table.DataBodyRange.Offset(1, 0).Resize(Table.DataBodyRange.Rows.count - 1, _
Table.DataBodyRange.Columns.count).Rows.Delete
On Error GoTo 0
End Sub
Greetings. The above code consolidates a folder of data that's held on excel spreadsheets into one master excel spreadsheet. The goal is to run a macro on Excel Spreadsheet named master on the worksheet named master which opens up other excel workbooks in the folder, takes the information, and puts it into a table in the worksheet "master". After which point, it becomes easy to see the information; so instead of it being held on hundreds of worksheets, the records are held on one worksheet.
The code uses a dictionary (reportDict) to temporarily store the information that is needed from the individual workbooks. The goal then is to take that information and place it in the master table at the bottom row, and then obviously add a new row either after a successful placement or before an attempted placement of data.
The code fails at the following line:
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
The failure description is "object or with variable not set" and so the issue is with the reportDict.Item(Key). My guess is that somehow VBA is not recognizing the dictionary item as stable, but I don't know how to correct this. Eventually the goal is to have code which does:
for each key in reportDict
- place the item which is mapped to the key at a unique row,column in the master table
- expand the table to accomodate necessary data
next key
Implicit default member calls are plaguing your code all over.
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
That's implicitly accessing Range.[_Default] off whatever worksheet is currently the ActiveSheet (did you mean that to be wkSheet.Cells?), to get the Key - since the Key parameter is a String, Range.[_Default] is implicitly coerced into one, and you have a string key. The actual dictionary item at that key though, isn't as lucky.
Here's a MCVE:
Public Sub Test()
Dim d As Dictionary
Set d = New Dictionary
d.Add "A1", Cells(1, 1)
Debug.Print IsObject(d("A1"))
End Sub
This procedure prints True to the debug pane (Ctrl+G): what you're storing in your dictionary isn't a bunch of string values, but a bunch of Range object references.
So when you do this:
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
You might as well have declared myInsert As Range, for it is one.
This is where things get interesting:
MsgBox (myInsert)
Nevermind the superfluous parentheses that force-evaluate the object's default member and pass it ByVal to the MsgBox function - here you're implicitly converting Range.[_Default] into a String. That probably works.
So why is this failing then?
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
Normally, it wouldn't. VBA would happily do this:
wkSheet.ListObjects(1).DataBodyRange.Cells(2, 1).[_Default] = reportDict.Item(Key).[_Default]
And write the value in the DataBodyRange of the ListObject at the specified location.
I think that's all just red herring. Write explicit code: if you mean to store the Value of a cell, store the Value of a cell. If you mean to assign the Value of a cell, assign the Value of a cell.
I can't replicate error 91 with this setup.
This, however:
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
...is also force-evaluating a ListObject's default member - so DeleteTableRows isn't receiving a ListObject, it's getting a String that contains the name of the object you've just dereferenced... but DeleteTableRows takes a ListObject parameter, so there's no way that code can even get to run FillTableRows - it has to blow up with a type mismatch before DeleteTableRows even gets to enter. In fact, it's a compile-time error.
So this is a rather long answer that doesn't get to the reason for error 91 on that specific line (I can't reproduce it), but highlights a metric ton of serious problems with your code that very likely are related to this error you're getting. Hope it helps.
You need to iterate through the dictionary's Keys collection.
dim k as variant, myInsert As Variant
for each k in reportDict.keys
debug.print reportDict.Item(k)
next k
I'm programming a Macro in VB for Excel 2013 that search for coincidences in different worksheets, and add a link to the cells that match.
I'm havin torubles to insert the link in the cell, since the link must be different for a range of cells, I need help here.
Here is my code
Dim bufferDetails As String
Dim tmpCell As String
Dim spot As String
Dim cell As Variant
Dim cellSpots As Variant
For Each cell In Worksheets("MMS-Locations").Range("D2:D1833")
If (cell.Value2 = "NULL") Then
cell.Value2 = "NULL"
Else
tmpCell = cell.Text
'A62
If (Left(tmpCell, 3) = "A62") Then
spot = spotName(tmpCell)
For Each cellSpots In Worksheets("DetailedMap").Range("G60:CF123")
If (cellSpots.Value2 = spot) Then
For Each linkToSpot In Worksheets("MMS-Locations").Range("H2:H1833")
Worksheets("MMS-Locations").Hyperlinks.Add _
Anchor:=Range(linkToSpot), _
Address:="http://example.microsoft.com", _
ScreenTip:="Microsoft Web Site", _
TextToDisplay:="Microsoft"
Next linkToSpot
Debug.Print ("Encontrado " + cellSpots)
End If
Next cellSpots
End If
End If
Next cell
End Sub
Function spotName(fullName As String) As String
Dim realSpot As String
Dim lenght As Integer
lenght = Len(fullName) - 3
realSpot = Right(fullName, lenght)
spotName = realSpot
End Function
As I was thinking the linkToSpot variable contains the actual cell in the range, so I can move my selection of the sell, but my code fails in there with this error:
Error in the Range method of the '_Global' object,
Just for reference, here is what I use to convert a phone number to an email for texting..setting it as a hyperlink in the current cell.
ActiveCell.Value = myNumbr
Set myRange = ActiveCell
ActiveSheet.Hyperlinks.Add anchor:=myRange, Address:="mailto:" & myRange.Value, TextToDisplay:=myRange.Value`
Keep your code simple to start with, until you find a working script, then add other items. Make good use of the F8 key to step through your code to find out exactly where an error occurs.
I have an issue with my VBA script which I'm not able to resolve, despite of all the researches I've made (Indeed, I tried to modify all the vba scripts which were near what I'm looking for, but it doesn't work).
Thank you very much for your help !
I have 2 sheets.
For the first one (ActiveSheet), I have a list.
For example :
Beurre
Creme fraiche
Fromage
Oeufs
Yaourts
In the second one ("Add value"), I have this list :
Chocolat
Carotte
Haricot
Fromage
Endive
I want the script to verify if the first value which is the sheet ("Add Value") exists in the ActiveSheet.
If it doesn't, it takes the second value in "Add Value" to make this verification. And so on with the other lines.
The loop has to stop when the script finds the same value. Then it does an action (MsgBox, for example).
For example, when the script researches "Chocolat" (the first line of the sheet "Add Value") in the ActiveSheet, it won't find it : it will use the second word to make this reasearch until it uses world "Fromage" which also exist in the second sheet.
It does the action (the msgbox), then quit the loop to continue with the other called macro which are in the script.
Moreover, I would like to choose the columns of the cell from "Add Value" each time I call the macro. Indeed, there will be several lists in this sheet.
Here is my macro. The issue is that I get the error 424 on the ligne If Not FindString Is Nothing Then
Public Sub Var()
Dim plage As Variant
Set plage = ActiveSheet.Range("A:A")
Dim col As Integer
Dim Ligne As Integer
Set Ligne = 2
Dim FindString As String
Set FindString = ThisWorkbook.Sheets("Add Value").Cells(Ligne, col).Value
End Sub
Sub Boucle_Ajout(col)
With plage
Do
If Not FindString Is Nothing Then
'do
Else
Ligne = Ligne + 1
End If
Loop While Not FindString Is Nothing
End With
End Sub
Then when I call the Macro, I only have to choose the column.
For example :
Call Boucle_Ajout(1)
Thank you very much for your help, because I am sick of not finding the solution.
PS : sorry for my english, I'm french.
Assuming the lines without numbers are in A1 to A5, this works:
Option Explicit
Const THECOLUMN = "A1"
Sub FindLineInOtherSheet()
Dim activeSheetRange As Range
Dim addValueRange As Range
Dim activeSheetLastRow As Integer
Dim addValueLastRow As Integer
Dim i As Integer
Dim n As Integer
Dim activeSheetCell As String
Dim addValueCell As String
'*
'* Setup
'*
Set activeSheetRange = ThisWorkbook.Sheets("activeSheet").Range(THECOLUMN)
activeSheetLastRow = findLastRow("activeSheet", THECOLUMN)
addValueLastRow = findLastRow("addValue", THECOLUMN)
'*
'* Loop through each cell in addValue for each cell in activeSheet
'*
For i = 1 To activeSheetLastRow
Set addValueRange = ThisWorkbook.Sheets("addValue").Range(THECOLUMN)
activeSheetCell = activeSheetRange.Value
For n = 1 To addValueLastRow
addValueCell = addValueRange.Value
If addValueCell = activeSheetCell Then
MsgBox ("Trouvé " & addValueCell)
End If
Set addValueRange = addValueRange.Offset(1, 0) 'Next row
Next n
Set activeSheetRange = activeSheetRange.Offset(1, 0)
Next i
End Sub
Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim WS As Worksheet
Set WS = Worksheets(Sheetname)
lastRow = WS.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = WS.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set WS = Nothing
findLastRow = lastRow
End Function
I am writing code which matches a date (from a file), puts this into a collection and then attempts to find this on a spreadsheet. Once it finds it, it puts the following two items in the collection in the two cells. When I run this I get the following error: "Object variable or With block variable not set". I have attempted to debug my code and it shows that after the first loop of the code below, the range object, "rthecell", changes to the proper value. Once the second iteration of the loop occurs the value of "rthecell" changes to "Nothing".
Ex:
Set rtheCell = Range("A:A").Find(What:=LineItem1)
rtheCell.Offset(, 1).Value = LineItem3
rtheCell.Offset(, 2).Value = LineItem2
Set rtheCell = Nothing
Again, everything works as intended on the first iteration of the loop but I receive the error once the second iteration occurs.
Here is the full code:
Sub InputData()
'Declare variables
Dim sFilePath As String
Dim sLineFromFile As String
Dim saLineItems() As String
Dim element As Variant
Dim col As Collection
Dim LineItem1 As String
Dim LineItem2 As String
Dim LineItem3 As String
Dim rtheCell As Range
Set col = New Collection
'Insert file path name here, this file will be overwritten each morning
sFilePath = "P:\Billing_Count.csv"
Open sFilePath For Input As #1
Do Until EOF(1)
Line Input #1, sLineFromFile
'Split each line into a string array
'First replace all space with comma, then replace all double comma with single comma
'Replace all commas with space
'Then perform split with all values separated by one space
sLineFromFile = Replace(sLineFromFile, Chr(32), ",")
sLineFromFile = Replace(sLineFromFile, ",,", ",")
sLineFromFile = Replace(sLineFromFile, ",", " ")
saLineItems = Split(sLineFromFile, " ")
'Add line from saLineItem array to a collection
For Each element In saLineItems
If element <> " " Then
col.Add element
End If
Next
Loop
Close #1
'Place each value of array into a smaller array of size 3
Dim i As Integer
i = 1
Do Until i > col.Count
'Place each value of array into a string-type variable
'This line is the date
LineItem1 = col.Item(i)
i = i + 1
'This line should be the BW count make sure to check
LineItem2 = col.Item(i)
i = i + 1
'This line should be the ECC count make sure to check
LineItem3 = col.Item(i)
i = i + 1
'Find the matching date in existing Daily Billing File (dates on Excel must be formatted as
'general or text) and add ECC and BW counts on adjacent fields
Set rtheCell = Range("A3:A37").Find(What:=LineItem1)
rtheCell.Offset(, 1).Value = LineItem3 'This is LineItem3 since we can ECC data to appear before BW
rtheCell.Offset(, 2).Value = LineItem2
Set rtheCell = Nothing
LineItem1 = 0
Loop
'Format cells to appear as number with no decimals
'Format cells to have horizontal alignment
Sheets(1).Range("B3:C50").NumberFormat = "0"
Sheets(1).Range("C3:C50").HorizontalAlignment = xlRight
End Sub
when you use the Range.Find method, typically you would either use the After:= parameter in subsequent calls or use the Range.FindNext method which assumes After:= the last found item. Since you are not modifying the actual found cells' value(s) in any way, you need to record the original found cell (typically the address) because eventually you will loop back to the original.
dim fndrng as range, fndstr as string
set fndrng = Range("A:A").Find(What:=LineItem1, after:=cells(rows.count, "A"))
if not fndrng is nothing then
fndstr = fndrng.address
do while True
'do stuff here
set fndrng = Range("A:A").FindNext(after:=fndrng)
if fndstr = fndrng.address then exit do
loop
end if
That should give you the idea of looping through all the matching calls until you loop back to the original. tbh, it is hard to adequately expand on the small amount of code supplied.
I currently want to store a bunch of graphs/chart objects to an array in VBA so I can either print them all out later or export them to a PDF. What is the best way to go about this? Do I have to use the shapes object or can I just do it with charts?
Sub onButtonClick()
Dim source As Worksheet, target As Worksheet
Set source = Workbooks("End Market Monitor.xlsm").Worksheets("Aero Graphs")
Set target = Sheet1
Dim ws As Worksheet
Dim title_name As String, search As String
search = ActiveCell.Offset(0, -5).Value
ReDim chartArray(1 To source.ChartObjects.Count) As Chart
For i = 1 To source.ChartObjects.Count
title_name = source.ChartObjects(i).Chart.ChartTitle.Text
counter = 1
If InStr(title_name, search) > 0 Then
Set chartArray(counter) = source.ChartObjects(i).Chart
counter = counter + 1
End If
Next
Set wsTemp = Sheets.Add
tp = 10
With wsTemp
For n = 1 To UBound(chartArray)
chartArray(n).CopyPicture
wsTemp.Range("A1").PasteSpecial
Selection.Top = tp
Selection.Left = 5
tp = tp + Selection.Height + 50
Next
End With
wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NewFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
You can get rid of ActiveCell.Select. The active cell is already selected. It's redundant/unnecessary. Won't cause any errors, but it doesn't need to be there.
There is an error with this line:
chartArray(i) = source.ChartObjects(i).Chart
You need to use the Set keyword when assigning to objects, and your chartArray() is an array of Objects.
Set chartArray(i) = source.ChartObjects(i).Chart
You should Dim all variables on their own line, or explicitly type them. This is wrong:
Dim source, target As Worksheet
Because VBA doesn't support implicit/in-line declarations. What you've really done is:
Dim source as Variant, target as Worksheet
Change to:
Dim source as Worksheet, target as Worksheet
Do the same with title_name and search.
The variable name is undeclared and unassigned. The variable i is undeclared. Not an error, but it's a bad habit to get in to. You can avoid this by using Option Explicit at the top of each module. You will need to assign name some value otherwise the Instr test will always be false, and no charts will be assigned to the array.
Your ReDim statement is wrong because you're re-dimensioning it within the loop, effectively erasing it every iteration. Put this outside of the for/next loop.
ReDim chartArray(1 to source.ChartObjects.Count)
Putting it all together, your code should be like:
Option Explicit
Sub onButtonClick()
Dim source as Worksheet, target As Worksheet
Set source = Workbooks("End Market Monitor.xlsm").Worksheets("Aero Graphs")
Set target = Sheet1
Dim title_name As String, search As String
Dim name as String
name = "???" '## YOU NEED TO UPDATE THIS SOMEHOW
search = Range("J3").Offset(0, -5).Value
ReDim chartArray(1 To source.ChartObjects.Count) As Chart
For i = 1 To source.ChartObjects.Count
title_name = source.ChartObjects(i).Chart.ChartTitle.Text
If InStr(title_name, name) > 0 Then
Set chartArray(i) = source.ChartObjects(i).Chart
End If
Next
End Sub
UPDATE
You can use this procedure for multiple buttons. Currently you had hard-coded Range("J3") representing the cell location of the one command button. You can modify it like this and then assign the same macro to all of the buttons:
search = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Make sure that the button's TopLeftCell is in Column F or higher. If this is in column A, B, C, D or E it will fail.