Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.
Related
I'm attempting to change any range selection that the user makes to column A only. I would like to keep the same row selction.
Sub update_test()
Dim ActSheet As Worksheet
Dim SelRange As Range
Set ActSheet = ActiveSheet
Set SelRange = Selection.Columns(1)
'My selected range is $S$1832:$S$1842
Debug.Print SelRange.Address
'I was hoping that the .Columns(1) would change my range to $A$1832:$A$1842
'But it is still $S$1832:$S$1842
End Sub
Managed to do it with offset and errors, seems a bit longwinded
Sub update_test()
Dim SelRange As Range
Set SelRange = Selection
Debug.Print SelRange.Address
On Error Resume Next
For i = -100 To 0 Step 1
Set SelRange = SelRange.Offset(0, i)
If Err.Number = 0 Then i = 0
Next i
On Error GoTo 0
Debug.Print SelRange.Address
end sub
I wish to copy data from Concur into my destination worksheet - Upload to Sun:
From Concur column J into UploadtoSun column D
From Concur column P into UploadtoSun column J
etc etc
My error message was the last sentence - Application defined or object defined error.
I'm not too sure how to write the last sentence. Can anyone assist ?
Dim ConcurLastRow As Long
Set Concur = ThisWorkbook.Worksheets("Concur")
Set UploadtoSun = ThisWorkbook.Worksheets("UploadtoSun")
Dim ConcurRngF As Range
Dim ConcurRngJ As Range
Dim ConcurRngK As Range
Dim ConcurRngO As Range
Dim ConcurRngP As Range
Dim UploadtoSunRngD As Range
Dim UploadtoSunRngF As Range
Dim UploadtoSunRngJ As Range
Dim UploadtoSunRngK As Range
Dim UploadtoSunRngL As Range
ConcurLastRow = Concur.Cells(Rows.Count, 1).End(xlUp).Row
UploadtoSunLastRow = Worksheets("UploadtoSun").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
Set ConcurRngF = Concur.Range("F11:G" & ConcurLastRow)
Set ConcurRngJ = Concur.Range("J11:K" & ConcurLastRow)
Set ConcurRngK = Concur.Range("K11:L" & ConcurLastRow)
Set ConcurRngO = Concur.Range("O11:P" & ConcurLastRow)
Set ConcurRngP = Concur.Range("P11:Q" & ConcurLastRow)
Set UploadtoSunRngD = UploadtoSun.Range("D2:E" & UploadtoSunLastRow)
Set UploadtoSunRngF = UploadtoSun.Range("F2:G" & UploadtoSunLastRow)
Set UploadtoSunRngJ = UploadtoSun.Range("J2:K" & UploadtoSunLastRow)
Set UploadtoSunRngK = UploadtoSun.Range("K2:L" & UploadtoSunLastRow)
Set UploadtoSunRngL = UploadtoSun.Range("L2:M" & UploadtoSunLastRow)
Worksheets("UploadtoSun").Range("UploadtoSunRngD").Copy Worksheets("Concur").Range("ConcurRngJ").Value
you could do something like this
Sub Copydata()
Dim lastRow As Long
lastRow = Worksheets("Concur").Range("J:Z").Find("*", , , , xlByRows, xlPrevious).Row
'copy range
Worksheets("Concur").Range("J1:" & "J" & lastRow).Copy Destination:=Worksheets("UploadtoSun").Range("D1")
'copy entire column
Worksheets("Concur").Range("J:J").Copy Destination:=Worksheets("UploadtoSun").Range("K:K")
End Sub
how to get the last row Excel VBA - selecting range to last completely blank row
In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub
This macro works on line 5 ,so i need this macro to work on all lines in one sheet instead of one macro for each line. Row X and email range A:L are copy paste in all lines i.e.( X1 A1:L1 | X2 ,A2:L2 ...)
Dim X5 As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("X5").Value = 1 And X5 <> 1 Then
ActiveSheet.Range("A5:L5").Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = " send thru macro "
.Item.To = "email#gmail.com"
.Item.Subject = "ALERT"
.Item.Send
End With
End If
X5 = Range("X5").Value
End Sub
Not sure if you got your answer or not so I am attempting to answer this question.
To make it flexible for any row, you can store the row of the current cell in a variable using Target.Row and then simply use that to construct your range.
Also to understand how Worksheet_Change works, you may want to see THIS
Is this what you are trying?
Dim X5 As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if the chnage happened to multiple cells
If Target.cell.CountLarge > 1 Then Exit Sub
Dim Rw As Long
'~~> Get the row number of the cell that was changed
Rw = Target.Row
If Range("X" & Rw).Value = 1 And X5 <> 1 Then
Application.EnableEvents = False
Range("A" & Rw & ":L" & Rw).Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = " send thru macro "
.Item.To = "email#gmail.com"
.Item.Subject = "ALERT"
.Item.Send
End With
End If
X5 = Range("X" & Rw).Value
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I've been working on this for 2 days. Basically I have 2 ListBoxes and I want a command button to compare the values and show the non-matching values (those that appear in the first listbox but not in the 2nd) and list them in the 3rd listbox. I'm not sure if this is the best way to go about it but here's my code. It errors on the line with the message:
Wrong number of arguments or invalid property assignment
My listboxes are named CompList1, CompList2 and CompList3.
Dim BoolAdd As Boolean, I As Long, j As Long
'Set initial Flag
BoolAdd = True
'If CompList2 is empty then abort operation
If CompList2.ListCount = 0 Then
MsgBox "Nothing to compare"
Exit Sub
'If CompList1 is empty then copy entire CompList2 to CompList3
ElseIf CompList1.ListCount = 0 Then
For I = 0 To CompList2.ListCount
CompList3.AddItem CompList2.Value
Next I
Else
For I = CompList2.ListCount - 1 To 0 Step -1
For j = 0 To CompList1.ListCount
If CompList2.ListCount(I) = CompList1.ListCount(j) Then
'If match found then abort
BoolAdd = False
Exit For
End If
DoEvents
Next j
'If not found then add to CompList3
If BoolAdd = True Then CompList3.AddItem CompList2.Value
DoEvents
Next I
End If
Some notes:
Dim tdf1 As TableDef
Dim tdf2 As TableDef
Dim db As Database
Set db = CurrentDb
Set tdf1 = db.TableDefs(Me.CompList1.RowSource)
For Each fld In tdf1.Fields
sFields = sFields & ";" & fld.Name
Next
sFields = sFields & ";"
Set tdf2 = db.TableDefs(Me.CompList2.RowSource)
For Each fld In tdf2.Fields
sf = ";" & fld.Name & ";"
sFields = Replace(sFields, sf, ";")
Next
Me.CompList3.RowSource = Mid(sFields,2)
Edit: