Macro Excel : create an excel for each city and send it to the email adresse

MicrosoftNewbie121 

It seems like there are a few issues that need to be addressed in the VBA code. I'll provide a refined version of the code that addresses the following:

1. Proper handling of the city names and email addresses.
2. Ensuring the new workbook is created and saved correctly for each city.
3. Properly looping through each city to create and send individual workbooks.
4. Handling the automation error by ensuring objects are cleaned up correctly.

Here is the improved version of the code:

Vba Code is untested backup your file

Sub CreateAndSendWorkbooks()
    Dim ws As Worksheet
    Dim cityRange As Range, cell As Range
    Dim cityName As String, emailAddress As String
    Dim newWorkbook As Workbook
    Dim newWorksheet As Worksheet
    Dim lastRow As Long
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim dataRange As Range

    ' Initialize Outlook
    Set OutlookApp = CreateObject("Outlook.Application")

    ' Set the worksheet containing your data
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change Sheet1 to the name of your data sheet

    ' Define the range with cities and email addresses
    Set cityRange = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)

    ' Loop through each city
    For Each cell In cityRange
        cityName = cell.Value
        emailAddress = cell.Offset(0, 1).Value ' Adjust if email is not in the next column

        ' Create a new workbook for each city
        Set newWorkbook = Workbooks.Add
        Set newWorksheet = newWorkbook.Sheets(1)
        newWorksheet.Name = cityName

        ' Copy the header
        ws.Rows(1).Copy Destination:=newWorksheet.Rows(1)

        ' Filter and copy data for each city
        ws.Range("A1").AutoFilter Field:=1, Criteria1:=cityName
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        Set dataRange = ws.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible)

        If Not dataRange Is Nothing Then
            dataRange.Copy Destination:=newWorksheet.Rows(2)
        End If

        ' Remove filter
        ws.AutoFilterMode = False

        ' Save the new workbook
        newWorkbook.SaveAs ThisWorkbook.Path & "\" & cityName & ".xlsx"

        ' Create and send email
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = emailAddress
            .Subject = "Data for " & cityName
            .Body = "Please find attached the data for " & cityName & "."
            .Attachments.Add newWorkbook.FullName
            .Send
        End With

        ' Close and save the new workbook
        newWorkbook.Close SaveChanges:=False
    Next cell

    ' Clean up
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

    MsgBox "Emails sent successfully!"
End Sub

Explanation of the Adjustments:

1. Proper Range Definition: Set cityRange is used to dynamically define the range of cities.
2. City Name Handling: Ensuring cityName is correctly obtained from the cell value.
3. Data Filtering and Copying: Using SpecialCells(xlCellTypeVisible) to copy only the visible (filtered) rows for the specific city.
4. Workbook Saving and Email Sending: Properly saving the new workbook and attaching it to the email before sending.
5. Error Handling for Empty Data: Added a check to ensure that dataRange is not Nothing before attempting to copy data to the new worksheet.
6. Removing Filters: Ensuring that filters are removed after copying the data.
7. Clean Up: Ensuring that Outlook objects are cleaned up after use.

Additional Tips:

• Column Offsets: Adjust cell.Offset(0, 1).Value if your email addresses are not in the column immediately next to the city names.
• Outlook Library Reference: Ensure you have set a reference to the Microsoft Outlook Object Library in the VBA editor (Tools > References > Microsoft Outlook XX.X Object Library).
• Testing: Always test the macro on a small dataset first to ensure it works as expected before running it on your entire data set. The text, steps and code were created with the help of AI.

My answers are voluntary and without guarantee!

Hope this will help you.