.To="email123456@yahoo.com"Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, irow As Long, r As Range, ws As Worksheet, sfilter As String
'pour chaque ligne de la feuille ("impayes") a partir de la ligne 5 jusqu'a la derniere ligne ou la colonne B est vide
For i = 5 To Range("B" & Rows.Count).End(xlUp).Row
' sfilter = No fiche chantier (colonne D)
sfilter = Cells(i, "d")
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 13 Then
ws.Activate
irow = ws.Cells.Find(What:=sfilter, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Row
If Cells(irow, "o") <> 0 Then
Rows(i).EntireRow.Delete
End If
End If
Next ws
Next i
End SubSub open_position_email()
Dim i As Integer, x As Integer, lcol As Integer, nb_orders As Integer
Dim dataWS As Worksheet, mainWS As Worksheet
Dim lastColumn As Integer
Dim LR As Integer
Dim i_text As Variant
Dim dic
Dim str As String
Set dic = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
Set dataWS = Sheets("Sheet1")
Set mainWS = Sheets("Open_Data")
lcol = 15
LR = dataWS.Cells(Rows.Count, 1).End(xlUp).Row
Cells(4, lcol).Select
'inputing a formula to determine how many days away this order is
Selection.Value = "Days Away"
With dataWS.Range(Cells(6, lcol), Cells(LR, lcol))
.FormulaR1C1 = "=RC[-5]-TODAY()"
.Value = .Value
End With
'' store in dictionary values of row with less than 3 days away from formula
For i = 6 To LR
If Cells(i, lcol).Value <= 3 Then
'str = Cells(i, 1) & "_" & Cells(i, 2) & "_" & Cells(i, 5) & "_" & Cells(i, 6) & "_" & Cells(i, 7) & "_" & Cells(i, 8) & "_" & Cells(i, 11) & "_" & Cells(i, 19)
If Cells(i, 7) > 0 Then
str = dataWS.Cells(i, 3) & " " & dataWS.Cells(i, 1) & dataWS.Cells(i, 2) & " debit" & dataWS.Cells(i, 7) & " contracts " & dataWS.Cells(i, 4) & " -- Order Delivery Day " & dataWS.Cells(i, lcol) & "days away"
Else
str = dataWS.Cells(i, 3) & " " & dataWS.Cells(i, 1) & dataWS.Cells(i, 2) & " credit" & dataWS.Cells(i, 8) & " contracts " & dataWS.Cells(i, 4) & " -- Order Delivery Day " & Cells(i, lcol) & "days away"
End If
If Not dic.exists(str) Then dic.Add str, i
nb_orders = nb_orders + 1
End If
Next i
'' with dictionary created, I want to send an outlook email with the body being all my dictionary items
Dim OutApp As Object
Dim OutMail As Object
Dim SubjectName As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SubjectName = "Orders less than 3 days! - " & Format(Now(), "dd-mmm-yy")
On Error Resume Next
With OutMail
.To = "name@company.com; name@company.com"
.CC = ""
.BCC = ""
.Subject = SubjectName
.Body = dic(str)
'.HTMLBody = RangetoHTML(dic)
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = NothingPublic Sub sendEmail(path, personName As String)
Dim book As Workbook
Set book = Workbooks.Open(path)
Dim Sht As Excel.Worksheet
Set Sht = book.Sheets("Summary")
Dim ShtLogo As Excel.Worksheet
Set ShtLogo = book.Sheets("Logo")
Dim rng As Range
Set rng = Sht.Range("C5:I39")
rng.Copy
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
OutMail.Display
Dim vInspector As Object
Set vInspector = OutMail.GetInspector
Dim wEditor As Object
Set wEditor = vInspector.WordEditor
With OutMail
.To = ""
.CC = ""
.Subject = ""
.Attachments.Add path
.Display
wEditor.Paragraphs(1).Range.Text = "Dear " & personName & Chr(11) & "Below is a snapshot of the inventory movement last week(details in the attached),relating to your Engagement Portfolio." & vbCr
wEditor.Paragraphs(2).Range.Paste
.Save
'.Close
End With
Set OutMail = Nothing
Set OutApp = Nothing
book.Save
book.Close
End SubOrigList = ""
For Each C1 In OrigRng
If Not OrigList Like "*" & C1 & "*" Then
If Len(OrigList) > 0 Then OrigList = OrigList & ","
OrigList = OrigList & C1
End If
Next C1
Origs = Split(OrigList, ",")If ProjData(6) >= CDbl(LW3) And _
ProjData(6) <= CDbl(LW1) Then
If Len(RecBullets) = 0 Then RecBullets = "<b><u>SUBMISSION RECEIVED</b></u><ul>"
RecBullets = RecBullets & "<li>" & ProjData(1) & " - " & ProjData(9) & ": " & ProjData(9) & "</li>"
End If
If InStr(ProjData(2), "Completed") > 0 And _
ProjData(3) >= CDbl(LW3) And _
ProjData(3) <= CDbl(LW1) Then
If Len(CompBullets) = 0 Then CompBullets = "<b><u>SUBMISSIONS COMPLETED</b></u><ul>"
CompBullets = CompBullets & "<li>" & ProjData(1) & " - " & ProjData(5) & ": " & ProjData(9) & "</li>"
End IfPrivate Sub CommandButton1_Click()
Dim Worksheet As Worksheet
Dim xrgvlist As Range
Dim z As Long
Dim temp As String
Dim main As String
Dim T As Long
Dim pctdone As Double
Set Worksheet = Worksheets("CARD")
If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub
Application.ScreenUpdating = False
Set progressindicator = New UserForm2
progressindicator.Show vbModeless
If TypeName(ActiveSheet) <> "Worksheet" Then
Unload progressindicator
Exit Sub
End If
With Worksheet
Set xrgvlist = Evaluate(.Range("B1").Validation.Formula1)
main = ActiveWorkbook.name
T = xrgvlist.Cells.Count
For z = 1 To Application.Min(xrgvlist.Cells.Count)
Windows(main).Activate
.Range("B1") = xrgvlist(z).Value
Select Case z
Case Is = 1:
Worksheets("CARD").Copy
temp = ActiveWorkbook.name
Case Is <> 1:
Worksheets("CARD").Copy after:=Workbooks(temp).Sheets(z - 1)
End Select
pctdone = (z) / T
With progressindicator
.Label1.Caption = "Building Card " & (z) & " of " & T
.FrameProgress.Caption = Format(pctdone, "0%")
.LabelProgress.Width = pctdone * (.FrameProgress.Width - 10)
End With
DoEvents
Next z
Unload progressindicator
Set progressindicator = Nothing
' Workbooks(temp).PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
' Workbooks(temp).Close savechanges:=False
'
End With
Application.ScreenUpdating = True
End SubDim myArr
'.....
'... some code
myArr = Array("Taxable Amount", "Tax Type", "VAT Amount", "GST Rate", "CGST Amount", "SGST Amount", _
"IGST Amount", "Cess Amount", "Fixed Cess Amount")
'... some code...
Set myArr = Nothing
Set myArr = Array("<1", "5", "12", "18", ">27") 'this line gives Type Mismatch error
... some code