Posts by Mavyak

Sub Remove_Dups_And_Sum_Column_F()
    Dim c As New ADODB.Connection
    Dim r As New ADODB.Recordset
    Dim w As Worksheet
    Dim x As Integer
    
    ThisWorkbook.Names.Add "MyTable", "=Original!" & ThisWorkbook.Worksheets("Original").Range("A1:F" & ThisWorkbook.Worksheets("Original").Range("A1").End(xlDown).Row).Address
    
    c.Open "Provider=Microsoft.Jet.OleDb.4.0;data source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
    r.Open "SELECT PART, D1, D2, S, Material, SUM(Amount) AS Amount FROM MyTable GROUP BY PART, D1, D2, S, Material", c, adOpenForwardOnly, adLockOptimistic
    
    ThisWorkbook.Names("MyTable").Delete
    
    Set w = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    w.Name = "Original_New"
    w.Range("A2").CopyFromRecordset r


    For x = 0 To r.Fields.Count - 1
        w.Range("A1").Offset(0, x) = r.Fields(x).Name
    Next x
    
ExitSub:
    Set w = Nothing
    Set p = Nothing
    
    If Not r Is Nothing Then
        If r.State <> adStateClosed Then
            r.Close
        End If
        Set r = Nothing
    End If
    
    If Not c Is Nothing Then
        If c.State <> adStateClosed Then
            c.Close
        End If
        Set c = Nothing
    End If
    
    Exit Sub
End Sub

Option Explicit
 
Sub GetAttachments_From_Inbox()
     
    On Error GoTo GetAttachments_err
     ' Declare variables
    Dim appOl As New Outlook.Application
    Dim ns As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim Item As Object
     'Dim Item As Outlook.Items
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    Dim i As Integer
    Dim sender As String
    Dim ext As String
    Dim Items As Outlook.Items
    Dim oc As Object
    Dim moveEmail As Boolean
    Set ns = appOl.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set Item = Inbox.Items
    Set myDestFolder = Inbox.Folders("Personal Mail")
     
     'Set oc = Application.ActiveInspector.CurrentItem
    i = 0
     
     ' Check Inbox for messages and exit if none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
        "Nothing Found"
        Exit Sub
    End If
     
     ' Check each message for attachments
    For Each Item In Inbox.Items
        'Resets teh moveEmail check-flag to false for
        'processing the next Email in the collection
        moveEmail = False
        
        'Identify the sender here
        sender = Right(Item.SenderEmailAddress, Len(Item.SenderEmailAddress) - InStrRev(Item.SenderEmailAddress, "="))
        
        'We only care about attachments or moving the email if the email is
        'from a specific sender, so skip processing if get_bank(sender) = unknown
        If get_bank(sender) <> "unknown" Then
            ' Save any attachments found
            For Each Atmt In Item.Attachments
                'We only care about Excel workbooks so skip other attachments
                If UCase(Right(Atmt.FileName, 4)) = ".XLS" Then
                    'Email has passed all checks:
                    '   1. From specific sender
                    '   2. Has attachments
                    '   3. At least one attachment is an Excel workbook
                    'so we set the moveEmail check-flag to True
                    moveEmail = True
                    
                    ext = Atmt.FileName
                    ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
                    
                    FileName = "S:\Loans\Data\For\Outlook\" & get_bank(sender) & ext
                    
                    'Atmt.SaveAsFile FileName
                    Atmt.SaveAsFile FileName
    
                    i = i + 1
                End If
            Next Atmt
            'this line is inside the if block but outside the attachment loop
            'so the email will only get moved once per applicable email that
            'had an Excel workbook as an attachment.
            If moveEmail Then
                Item.Move myDestFolder
            End If
        End If
    Next Item
     
    ' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & "  attached files." _
        & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
     ' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Set appOl = Nothing
    Exit Sub
     ' Handle errors
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub
 
Function get_bank(sender As String) As String
     
    Select Case sender
    Case "[email protected]"
        get_bank = "nameb"
         
    Case Else
        get_bank = "unknown"
         
    End Select
End Function

For Each Item In Inbox.Items
        If get_bank(Sender) <> "unknown" Then
         ' Save any attachments found
            For Each Atmt In Item.Attachments
                 ' This filename path must exist! Change folder name as necessary.
                Sender = Atmt.Parent.SenderEmailAddress
                Sender = Right(Sender, Len(Sender) - InStrRev(Sender, "="))
                 
                ext = Atmt.Filename
                ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
                Filename = "S:\Loans\Data\For\Outlook\" & get_bank(Sender) & ext
                 'Atmt.SaveAsFile FileName
                 
                Atmt.SaveAsFile Filename
                i = i + 1
            Next Atmt
            Item.Move myDestFolder
        End If
    Next Item

sub create_excel_report_from_sql
dim c as adodb.connection
dim r as adodb.recordset


set c = new adodb.connection
c.open "your database connection string here"


set r = new adodb.recordset


set r = c.execute("your sql statement here")


thisworkbook.worksheets(1).range("A1").copyfromrecordset r


r.close
c.close
set r = nothing
set c = nothing
end sub

ExitSub:
    If Not cn Is Nothing Then
        If cn.State <> adStateClosed Then
            cn.Close
        End If
        Set cn = Nothing
    End If
    If Not rs Is Nothing Then
        If rs.State <> adStateClosed Then
            rs.Close
        End If
        Set rs = Nothing
    End If
    Exit Sub
errHandler:
    If cn.Errors.Count > 0 Then
        Debug.Print "ADO Error #" & cn.Errors(0).NativeError & ": " & cn.Errors(0).Description
        cn.Errors.Clear
    Else
        Debug.Print "VBA Error #" & Err.Number & ": " & Err.Description
        Err.Clear
    End If
    Stop
    Resume ExitSub