VBA custom format adjustment

Hi there,

See if the attached version of your workbook does what you need - it uses the following code:

Option Explicit


'=========================================================================================
'=========================================================================================


Const miFIRST_DATA_ROW_NO   As Integer = 3
Const msLIST_SHEET_NAME     As String = "List"
Const msNAME_COLUMN         As String = "B"


'=========================================================================================
'=========================================================================================


Sub ScanThroughNames()

    Dim sCurrentName    As String
    Dim rNameColumn     As Range
    Dim iLastRowNo      As Integer
    Dim objOutlook      As Object
    Dim wksList         As Worksheet
    Dim iRowNo          As Integer

    Call CreateOutlookInstance(objOutlook:=objOutlook)

    Set wksList = ThisWorkbook.Worksheets(msLIST_SHEET_NAME)

    Set rNameColumn = wksList.Columns(msNAME_COLUMN)

    With wksList.UsedRange
        iLastRowNo = .Rows(.Rows.Count).Row
    End With

    sCurrentName = vbNullString

    For iRowNo = miFIRST_DATA_ROW_NO To iLastRowNo

        If rNameColumn.Cells(iRowNo, 1).Value <> sCurrentName Then

            sCurrentName = rNameColumn.Cells(iRowNo, 1).Value

            Call CreateWorkbook(wksList, sCurrentName, iLastRowNo)

        End If

    Next iRowNo

    Set objOutlook = Nothing

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateOutlookInstance(objOutlook As Object)

    On Error Resume Next
        Set objOutlook = Nothing
        Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
    End If

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateWorkbook(wksList As Worksheet, sCurrentName As String, _
                           iLastRowNo As Integer)

    Dim wksCopyOfList   As Worksheet
    Dim rNameColumn     As Range
    Dim rNameCell       As Range
    Dim iRowNo          As Integer

    wksList.Copy
    Set wksCopyOfList = ActiveSheet

    Set rNameColumn = wksCopyOfList.Columns(msNAME_COLUMN)

    For iRowNo = iLastRowNo To miFIRST_DATA_ROW_NO Step -1

        Set rNameCell = rNameColumn.Cells(iRowNo, 1)

        If rNameCell.Value <> sCurrentName Then
            rNameCell.EntireRow.Delete
        End If

    Next iRowNo

    Call SaveWorkbook(sCurrentName:=sCurrentName)

End Sub


'=========================================================================================
'=========================================================================================


Private Sub SaveWorkbook(sCurrentName As String)

    Const sADDRESS_COLUMN   As String = "R"
    Const sEXTENSION        As String = ".xlsx"

    Dim sEmailAddress       As String
    Dim sFullName           As String
    Dim sFilePath           As String
    Dim sFileName           As String

    sFilePath = Environ$("TEMP")
    sFileName = sCurrentName

    sFullName = sFilePath & "\" & sFileName & sEXTENSION

    sEmailAddress = ActiveSheet.Range(sADDRESS_COLUMN & miFIRST_DATA_ROW_NO).Value

    ActiveWorkbook.SaveAs Filename:=sFullName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close

    Call CreateEmail(sCurrentName:=sCurrentName, sEmailAddress:=sEmailAddress, _
                     sFullName:=sFullName)

    Kill PathName:=sFullName

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateEmail(sCurrentName As String, sEmailAddress As String, _
                        sFullName As String)

    Dim sSignature  As String
    Dim objOutlook  As Object
    Dim objEmail    As Object

    Set objOutlook = GetObject(, "Outlook.Application")
    Set objEmail = objOutlook.CreateItem(0)

    With objEmail

        .Display

        sSignature = .HTMLBody

        .To = sEmailAddress
        .Subject = "Requests"

        .HTMLBody = "Dear " & sCurrentName & "," & _
                    "<br><br>" & _
                    "Please find attached a list of YOUR OPEN REQUESTS. " & _
                    "Please review the open requests and update ONLY the last 3 blue columns with the current status." & _
                    "<br><br>" & _
                    "Thank you and Best Regards," & _
                     sSignature

        .Attachments.Add sFullName
        .Display
        '.Send - Replace with this to have it sent directly'
    
    End With

End Sub

The highlighted values may be changed to suit your requirements.


Hope this helps - please let me know how you get on.

Regards,

Greg M

Hi again,

The attached version should ensure that colour schemes are copied correctly from the source workbook.

The highlighted line has been added to the existing routine:

Private Sub CreateWorkbook(wksList As Worksheet, sCurrentName As String, _
                           iLastRowNo As Integer)

    Dim wksCopyOfList   As Worksheet
    Dim rNameColumn     As Range
    Dim rNameCell       As Range
    Dim iRowNo          As Integer

    wksList.Copy
    Set wksCopyOfList = ActiveSheet

    Set rNameColumn = wksCopyOfList.Columns(msNAME_COLUMN)

    For iRowNo = iLastRowNo To miFIRST_DATA_ROW_NO Step -1

        Set rNameCell = rNameColumn.Cells(iRowNo, 1)

        If rNameCell.Value <> sCurrentName Then
            rNameCell.EntireRow.Delete
        End If

    Next iRowNo

    ActiveWorkbook.ApplyTheme ThisWorkbook.FullName

    Call SaveWorkbook(sCurrentName:=sCurrentName)

End Sub

Hope this helps.

Regards,

Greg M

Hello Greg,

This seems fine. I would have one more requirement if you would be able to assist:

I would like to remove Column R (e-mail address) and have the code perform a vlookup directly by looking for the Names (from Column B) in Sheet "Addresses" and generate the e-mail accordingly (with the relevant data) to the Name's contact stated there.

Therefor, the code should attach the xlsx containing Sheet "List" in whatever form and format I adjust it (even if I add extra columns/remove columns/change format/etc).

Huge thanks for this

Ok, I'll see what I can do tomorrow

Hi Greg and thanks again ,

I don't see the attachment in this most recent post. Was it intended to be here?

Oops - mea culpa!

Hi Greg

Have you got the chance to review the above reply?

Hi again,

Hey, nobody said anything about nine thousand rows!

That sort of number makes a BIG difference to the approach used in producing what is required!

The original approach deleted unwanted rows on a row-by-row basis - it takes quite some time to individually delete the large number of rows involved!


The attached version prefixes each instance of the current Addressee Name with an "AAAAA" prefix and then sorts the worksheet to bring the current Addressee to the top of the list. The prefix is then removed.

When this has been done, the unwanted Addressee rows can be deleted in bulk - this takes far less time than deleting them individually.

The following code is used:

Option Explicit


'=========================================================================================
'=========================================================================================


Const miFIRST_DATA_ROW_NO   As Integer = 3
Const msLIST_SHEET_NAME     As String = "List"
Const msNAME_COLUMN         As String = "B"


'=========================================================================================
'=========================================================================================


Private mobjOutlook         As Object


'=========================================================================================
'=========================================================================================


Sub ScanThroughNames()

    Dim sCurrentName    As String
    Dim rNameColumn     As Range
    Dim iLastRowNo      As Integer
    Dim objOutlook      As Object
    Dim wksList         As Worksheet
    Dim iRowNo          As Integer

    Call CreateOutlookInstance(objOutlook:=objOutlook)

    Set wksList = ThisWorkbook.Worksheets(msLIST_SHEET_NAME)

    Set rNameColumn = wksList.Columns(msNAME_COLUMN)

    With wksList.UsedRange
        iLastRowNo = .Rows(.Rows.Count).Row
    End With

    sCurrentName = vbNullString

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

        For iRowNo = miFIRST_DATA_ROW_NO To iLastRowNo

            If rNameColumn.Cells(iRowNo, 1).Value <> sCurrentName Then

                sCurrentName = rNameColumn.Cells(iRowNo, 1).Value

            If sCurrentName <> vbNullString Then
                Call CreateWorkbook(wksList, sCurrentName, iLastRowNo)
            End If

        End If

        Next iRowNo

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    Set objOutlook = Nothing

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateOutlookInstance(objOutlook As Object)

    On Error Resume Next
        Set mobjOutlook = Nothing
        Set mobjOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If objOutlook Is Nothing Then
        Set mobjOutlook = CreateObject("Outlook.Application")
    End If

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateWorkbook(wksList As Worksheet, sCurrentName As String, _
                           iLastRowNo As Integer)

    Dim wksCopyOfList As Worksheet

    wksList.Copy

    Set wksCopyOfList = ActiveSheet

    Call MoveCurrentNameRowsToTopOfList(wksCopyOfList:=wksCopyOfList, _
                                        sCurrentName:=sCurrentName, _
                                        iLastRowNo:=iLastRowNo)

    Call DeleteUnwantedRows(wksCopyOfList:=wksCopyOfList, _
                            iLastRowNo:=iLastRowNo)

    ActiveWorkbook.ApplyTheme ThisWorkbook.FullName

    Call SaveWorkbook(sCurrentName:=sCurrentName)

End Sub


'=========================================================================================
'=========================================================================================


Private Sub MoveCurrentNameRowsToTopOfList(wksCopyOfList As Worksheet, _
                                           sCurrentName As String, _
                                           iLastRowNo As Integer)

    Const sPREFIX_FOR_SORTING   As String = "AAAAA"

    Dim rRangeToSort            As Range
    Dim rNameColumn             As Range
    Dim rNameCells              As Range

    Set rNameColumn = wksCopyOfList.Columns(msNAME_COLUMN)

    With rNameColumn

        Set rNameCells = Range(.Rows(miFIRST_DATA_ROW_NO), _
                               .Rows(iLastRowNo))

    End With

    rNameCells.Replace What:=sCurrentName, _
                       Replacement:=sPREFIX_FOR_SORTING & sCurrentName, _
                       LookAt:=xlWhole

        With wksCopyOfList

            Set rRangeToSort = Range(.Rows(miFIRST_DATA_ROW_NO), _
                                     .Rows(iLastRowNo))

        End With

        rRangeToSort.Sort Key1:=rNameCells.Cells(1, 1), Order1:=xlAscending, Header:=xlNo

    rNameCells.Replace What:=sPREFIX_FOR_SORTING, _
                       Replacement:=vbNullString, _
                       LookAt:=xlPart

End Sub


'=========================================================================================
'=========================================================================================


Private Sub DeleteUnwantedRows(wksCopyOfList As Worksheet, _
                               iLastRowNo As Integer)

    Dim iFirstRowToDelete       As Integer
    Dim rRangeToDelete          As Range
    Dim rNameColumn             As Range
    Dim rNameCells              As Range
    Dim rNameCell               As Range

    Set rNameColumn = wksCopyOfList.Columns(msNAME_COLUMN)

    With rNameColumn

        Set rNameCells = Range(.Rows(miFIRST_DATA_ROW_NO), _
                               .Rows(iLastRowNo))

    End With

    For Each rNameCell In rNameCells.Cells

        If rNameCell.Value <> rNameCell.Offset(1, 0).Value Then
            iFirstRowToDelete = rNameCell.Row + 1
            Exit For
        End If

    Next rNameCell

    With wksCopyOfList

        Set rRangeToDelete = Range(.Rows(iFirstRowToDelete), _
                                   .Rows(iLastRowNo))

    End With

    rRangeToDelete.EntireRow.Delete

End Sub


'=========================================================================================
'=========================================================================================


Private Sub SaveWorkbook(sCurrentName As String)

    Const sADDRESSES_SHEET_NAME As String = "Addresses"
    Const sEXTENSION            As String = ".xlsx"

    Dim sEmailAddress           As String
    Dim wksAddresses            As Worksheet
    Dim sFullName               As String
    Dim sFilePath               As String
    Dim sFileName               As String

    sFilePath = Environ$("TEMP")
    sFileName = sCurrentName

    sFullName = sFilePath & "\" & sFileName & sEXTENSION

    Set wksAddresses = ThisWorkbook.Worksheets(sADDRESSES_SHEET_NAME)

    wksAddresses.Range("ptrCurrentName").Value = sCurrentName

    sEmailAddress = wksAddresses.Range("ptrCurrentAddress").Value

    ActiveWorkbook.SaveAs Filename:=sFullName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close

    Call CreateEmail(sCurrentName:=sCurrentName, sEmailAddress:=sEmailAddress, _
                     sFullName:=sFullName)

    Kill PathName:=sFullName

End Sub


'=========================================================================================
'=========================================================================================


Private Sub CreateEmail(sCurrentName As String, sEmailAddress As String, _
                        sFullName As String)

    Const iMAIL_ITEM    As Integer = 0

    Dim sSignature      As String
    Dim objEmail        As Object

    Set objEmail = mobjOutlook.CreateItem(iMAIL_ITEM)

    With objEmail

        .Display

        sSignature = .HTMLBody

        .To = sEmailAddress
        .Subject = "Requests"

        .HTMLBody = "Dear " & sCurrentName & "," & _
                    "<br><br>" & _
                    "Please find attached a list of YOUR OPEN REQUESTS. " & _
                    "Please review the open requests and update ONLY the last 3 blue columns with the current status." & _
                    "<br><br>" & _
                    "Thank you and Best Regards," & _
                     sSignature

        .Attachments.Add sFullName
'       Include the following line to send the email automatically
'''        .Send
    
    End With

End Sub

The highlighted values can be altered to suit your requirements.


Hope this helps - as before, please let me know how you get on.

Regards,

Greg M

Greg, you're a god!

Let me play around with it and test all the scenarios and I'll get back to you.