Posts by jaslake

Sub LoopThroughDirectory()
    Dim MyFile As String
    Dim eRow As Long
    Dim tgtWb As Workbook
    Dim tgtWs As Worksheet
    Dim srcWb As Workbook
    Dim srcWs As Worksheet
    Dim LR As Long
    Dim FilePath As String
    FilePath = ThisWorkbook.Path & "\"
    '    Debug.Print FilePath
    Set tgtWb = ThisWorkbook
    Set tgtWs = tgtWb.Sheets("Sheet1")
    MyFile = Dir(FilePath)
    '    Debug.Print MyFile
    Application.ScreenUpdating = False
    Do While Len(MyFile) > 0
        If MyFile = "zMaster.xlsm" Then
            Exit Sub
        End If
        Set srcWb = Workbooks.Open(FilePath & MyFile)
        Set srcWs = srcWb.Sheets("Sheet1")
        With srcWs
            LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                             SearchDirection:=xlPrevious).Row
            If Not .AutoFilterMode Then
                .Rows("1:1").AutoFilter
            End If
            .Range("A1:E" & LR).AutoFilter Field:=5, Criteria1:="="
            If Not .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 = 0 Then
                .Range("A2:D" & LR).SpecialCells(xlCellTypeVisible).Copy
                eRow = tgtWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                tgtWs.Cells(eRow, "A").PasteSpecial
                .Range(.Cells(2, 5), .Cells(LR, 5)).SpecialCells(xlCellTypeVisible).Value = "Yes"
            Else
                .AutoFilterMode = False
            End If
            Application.DisplayAlerts = False
            srcWb.Close True
            Application.DisplayAlerts = True
            MyFile = Dir
        End With
    Loop
    tgtWb.Save
    Application.ScreenUpdating = True
End Sub

Sub sendmail()  
   Dim OutApp       As Object
   Dim OutMail      As Object
   Dim SigString    As String
   Dim Signature    As String
   Dim ws           As Worksheet
   Dim cel          As Range
   Dim LR           As Long




   Set ws = Sheets("MRM")
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      If Not .AutoFilterMode Then
         .Range("A3:P3").AutoFilter
      End If
      .Range("A3:P" & LR).AutoFilter Field:=16, Criteria1:="<>"
      If .Range("P3:P" & LR).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
         For Each cel In .Range("P4:P" & LR).SpecialCells(xlCellTypeVisible)
            EmailTo = .Cells(cel.Row, "J").Value
            CCto = .Cells(cel.Row, "K").Value
            Subj = .Cells(cel.Row, "L").Value
            Filepath = .Cells(cel.Row, "M").Value
            msg = .Cells(cel.Row, "N").Value




            With Application
               .EnableEvents = False
               .ScreenUpdating = False
            End With
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)




            SigString = Environ("appdata") & _
                        "\Microsoft\Signatures\mrm.htm"




            If Dir(SigString) <> "" Then
               Signature = GetBoiler(SigString)
            Else
               Signature = ""
            End If
            On Error Resume Next
            With OutMail
               .To = EmailTo
               .CC = CCto
               .BCC = ""
               .Subject = Subj
               .HTMLBody = msg & "<br>" & Signature
               '.body = msg & vbNewLine & vbNewLine & Signature
               ' .Attachments.Add Filepath 'Uncomment this Line if you've added attachments
               .Display   '.Send   'or use .Display
            End With
         Next cel
      End If
      .AutoFilterMode = False
   End With




   On Error GoTo 0
   Set OutMail = Nothing
   Set OutApp = Nothing




   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With
End Sub




Function GetBoiler(ByVal sFile As String) As String
   '**** Kusleika
   Dim fso          As Object
   Dim ts           As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
   GetBoiler = ts.readall
   ts.Close
End Function

Option Explicit


Sub UpdateRecords()
   Dim ws           As Worksheet
   Dim LR           As Long
   Dim lLoop        As Long
   Dim rFoundCell   As Range




   Application.ScreenUpdating = False
   Set ws = Sheets("Sheet1")
   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      With .Range(.Cells(7, 1), .Cells(LR, 1))
         Set rFoundCell = .Cells(1, 1)
         For lLoop = 1 To WorksheetFunction.CountIf(.Cells, "date")




            Set rFoundCell = .Find(What:="date", After:=rFoundCell, _
                                   LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                   SearchDirection:=xlNext, MatchCase:=False)
            ws.Range("A1:H5").Copy
            .Cells(rFoundCell.Row - 6, "A").Insert Shift:=xlDown
         Next lLoop
      End With
      .AutoFilterMode = False
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      .Range("A1:A" & LR).AutoFilter Field:=1, Criteria1:="date"
      .Range("A6:A" & LR).SpecialCells(xlCellTypeVisible).EntireRow.Delete
      .AutoFilterMode = False




   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True




End Sub

Option Explicit


Sub Delete_Me()
Dim ws As Worksheet
Dim LR As Long




Set ws = Sheet1




With ws
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row




If Not .AutoFilterMode Then
      .Rows("2:2").AutoFilter
    End If
    
    .Range("$A$2:$JH" & LR).AutoFilter Field:=6, Criteria1:= _
        "<>USI - GSC - L1", Operator:=xlAnd
        Application.DisplayAlerts = False
    .UsedRange.Offset(2, 0).SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    .AutoFilterMode = False
End With
End Sub

Option Explicit


Sub MoveRecords()
   Dim wsSRC        As Worksheet
   Dim wsTGT        As Worksheet
   Dim lStart       As Long
   Dim rStartCell   As Range
   Dim rEndCell     As Range
   Dim LC           As Long
   Dim wsSrcLR      As Long
   Dim wsTgtLR      As Long




   Set wsSRC = Sheets("Sheet1") 'Raw Data
   Set wsTGT = Sheets("Sheet2") 'Output Data




   Application.ScreenUpdating = False
   With wsTGT
      .Cells.Clear 'Clear the Output Data
      wsTgtLR = 2  'Set the Start Row
   End With




   With wsSRC  'With Raw Data Sheet
      
      'Find the Last Column Number
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      
      'Find the Last used Row in Column A
      wsSrcLR = .Range("A" & .Rows.Count).End(xlUp).Row




      'Where do we start looking for "DOC"?
      Set rStartCell = .Cells(1, 1)
      
      'Count the number of incidents  of "DOC" and cycle through them
      For lStart = 1 To WorksheetFunction.CountIf(.Cells, "DOC")




         'Find "DOC"...that's our Starting Row
         Set rStartCell = .Columns(1).Find(What:="DOC", After:=rStartCell, _
                                           LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                           SearchDirection:=xlNext, MatchCase:=False)
                                           
         MsgBox "Found DOC at Row " & rStartCell.Row  '<---Can be Deleted




         'From that ROW of "DOC" find the first incident of "TABLE*" (with Wildcard)
         Set rEndCell = .Range(.Cells(rStartCell.Row, "A"), .Cells(wsSrcLR, "A")) _
                        .Find("TABLE*", , xlValues, xlPart, xlByRows, xlNext, False)
                        
         MsgBox "Found TABLE at Row " & rEndCell.Row '<---Can be Deleted




         'Copy that Range of Cells
         .Range(.Cells(rStartCell.Row, "A"), .Cells(rEndCell.Row - 2, LC)).Copy
         
         'Paste that Range of Cells to the Target Worksheet @ Range A and the Last Row
         wsTGT.Range("A" & wsTgtLR).PasteSpecial (xlPasteValues)
         
         'Find the New Last Row in the Target Worksheet
         wsTgtLR = wsTGT.Range("A" & Rows.Count).End(xlUp).Row + 2
         
      'Look for the Next incident of "DOC"
      Next lStart
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = False
End Sub