Posts by PCI

Option Explicit


Sub Macro1()
Dim K As String, O As String, T As String
Dim Ord As Integer


O = Range("b2"): K = Range("b3")
If O = "xlAscending" Then Ord = 1
If O = "xlDescending" Then Ord = 2


ActiveWorkbook.Worksheets("data").ListObjects("data").Sort.SortFields.Clear


T = "data[[#All],[" & K & "]]"
ActiveWorkbook.Worksheets("data").ListObjects("data").Sort.SortFields.Add2 _
Key:=Range(T), SortOn:=xlSortOnValues, _
Order:=Ord, DataOption:=xlSortNormal


With ActiveWorkbook.Worksheets("data").ListObjects("data").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Option Explicit


Sub AnniversaryEmail()
Dim Rg  As Range
For Each Rg In Range([F3], Cells(Rows.Count, "F").End(3))
If (Rg.Value = Date) Then




Dim DestEmail  As String
Dim CopyEmail  As String
Dim WkRg As Range
Dim F


Dim EmailTopic As String
Dim EmailWhat As String
Dim EmailSubject  As String
Dim EmailStart1 As String, EmailStart2 As String
Dim EmailEnd1 As String, EmailEnd2 As String
Dim EmailBody  As String
Dim FullEmail  As String


Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)


'---  Email info
EmailSubject = Range("EmailSubject")
EmailStart1 = Range("EmailStart1")
EmailStart2 = Range("EmailStart2")
EmailBody = Range("EmailBody")
EmailEnd1 = Range("EmailEnd1")
EmailEnd2 = Range("EmailEnd2")


FullEmail = EmailStart1 _
& Chr(10) & Chr(10) & _
EmailStart2 _
& Chr(10) & Chr(10) & _
EmailBody _
& Chr(10) & Chr(10) & _
EmailEnd1 _
& Chr(10) & Chr(10) & _
EmailEnd2 _
& Chr(10)


'---  People info
DestEmail = Rg.Offset(0, -2)
'        CopyEmail = Range("CopyEmail")


'---  Send Email
Application.DisplayAlerts = False
With myItem
If (DestEmail <> "") Then
.To = DestEmail
.CC = CopyEmail
.Subject = EmailSubject
.Body = FullEmail
.Send
End If
End With
Application.DisplayAlerts = True


'---  Close
Set myItem = Nothing
Set myOlApp = Nothing




End If
Next
MsgBox " Job done", , "INFORMATION"
End Sub

Option E
xplicit


Sub Treat()
Const WkCol = "C"
Const WkChar = "C"
Const DstWsN = "RAWS Closed Jobs"
Dim LR1  As Integer, LR2  As Integer, I  As Integer
    LR1 = Cells(Rows.Count, WkCol).End(3).Row
    For I = LR1 To 2 Step -1
        If (Cells(I, WkCol) = WkChar) Then
            With Sheets(DstWsN)
                LR2 = .Cells(Rows.Count, WkCol).End(3).Row
                Cells(I, WkCol).EntireRow.Copy Destination:=.Cells(LR2 + 1, 1)
            End With
                Cells(I, WkCol).EntireRow.Delete Shift:=xlUp
        End If
    Next
End Sub

Option Explicit


Sub Treat()
Const WkCol = "C"
Const WkChar = "C"
Const DstWsN = "RAWS Closed Jobs"
Dim LR1  As Integer, LR2  As Integer, I  As Integer
    LR1 = Cells(Rows.Count, WkCol).End(3).Row
    For I = LR1 To 2 Step -1
        If (Cells(I, WkCol) = WkChar) Then
            With Sheets(DstWsN)
                LR2 = .Cells(Rows.Count, WkCol).End(3).Row
                Cells(I, WkCol).EntireRow.Copy Destination:=.Cells(LR2 + 1, 1)
            End With
                Cells(I, WkCol).EntireRow.Delete Shift:=xlUp
        End If
    Next
End Sub

Option Explicit


Sub SplitData()
Const StartStg As String = "UTC NOTE"
Const EndStg As String = "ENDNOTE"
Const FR As Integer = 2
Dim WkStg  As String
Dim LC  As Integer, LR  As Integer, I As Integer, J As Integer
Dim StNb As Integer, EndNb As Integer
Dim SFlg  As Boolean
Dim T
    Application.ScreenUpdating = False
    LR = Cells(Rows.Count, 1).End(3).Row
    LC = Cells(FR, Columns.Count).End(xlToLeft).Column
    For I = FR + 1 To LR
        SFlg = True
        WkStg = Cells(I, 1)
        J = 1
        While SFlg
            With Application
                T = Not (.IsError(.Search(StartStg & "*" & EndStg, WkStg, J)))
                If (T) Then
                    StNb = .Search(StartStg, WkStg, J + 1) + Len(StartStg) + 1
                    EndNb = .Search(EndStg, WkStg, J + 1)
                    Cells(I, LC + 1) = Mid(WkStg, StNb, EndNb - StNb)
                    J = EndNb
                Else
                    SFlg = False
                End If
            End With
        Wend
    Next I
    Application.ScreenUpdating = True
    MsgBox (" Job Done")
End Sub

Option Explicit


Sub SplitData()
Const StartStg As String = "UTC NOTE"
Const EndStg As String = "ENDNOTE"
Dim WkStg  As String
Dim LC  As Integer, LR  As Integer, I As Integer, J As Integer
Dim StNb As Integer, EndNb As Integer
Dim SFlg  As Boolean
Dim T
    LR = Cells(Rows.Count, 1).End(3).Row
    For I = 3 To LR
        SFlg = True
        WkStg = Cells(I, 1)
        J = 1
        While SFlg
            With Application
                T = Not (.IsError(.Search(StartStg & "*" & EndStg, WkStg, J)))
                If (T) Then
                    LC = Cells(I, Columns.Count).End(xlToLeft).Column
                    StNb = .Search(StartStg, WkStg, J + 1) + Len(StartStg) + 1
                    EndNb = .Search(EndStg, WkStg, J + 1)
                    Cells(I, LC + 1) = Mid(WkStg, StNb, EndNb - StNb)
                    J = EndNb
                Else
                    SFlg = False
                End If
            End With
        Wend
    Next I
End Sub