用VBA代码实现需求: 1.WS2循环,从第二行开始循环,确认B列的值,B列值不同的值用不同颜色背景标识,相同值用相同颜色标识, 2.根据不同颜色,每个新建一个excel文件在当前文件夹下,新建的excel根据颜色的B列值命名 3.如果B列同样颜色的值有多少行,则将B列值同颜色的整行,复制粘贴多少行整行,到新建的值的excel,从第二行开始粘贴 4.批量发送邮件,WS2的B列有几个颜色就发送几封邮件,每封邮件的附件是以该颜色的B列值为名字,首件人是该颜色的B列值,同颜色的B列值无论多少个,都是只发送一个颜色一封邮件
时间: 2023-10-22 18:09:25 浏览: 40
以下是VBA代码实现上述需求的示例代码:
```
Sub SortByColor()
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim lastRow As Long
lastRow = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
Dim colorDict As Object
Set colorDict = CreateObject("Scripting.Dictionary")
Dim colorIndex As Long
colorIndex = 1
Dim color As Variant
For i = 2 To lastRow
color = ws2.Cells(i, "B").Interior.Color
If Not colorDict.Exists(color) Then
colorDict.Add color, colorIndex
colorIndex = colorIndex + 1
End If
Next i
Dim newWb As Workbook
Dim newWs As Worksheet
Dim fileRoot As String
fileRoot = ThisWorkbook.Path & "\"
For Each color In colorDict.keys
Set newWb = Workbooks.Add
Set newWs = newWb.Sheets(1)
newWs.Name = "Sheet1"
newWb.SaveAs Filename:=fileRoot & color & ".xlsx"
For i = 2 To lastRow
If ws2.Cells(i, "B").Interior.Color = color Then
ws2.Rows(i).Copy newWs.Rows(newWs.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
newWs.Rows(1).Value = ws2.Rows(1).Value
newWb.Save
Dim outlookApp As Object
Set outlookApp = CreateObject("Outlook.Application")
Dim outlookMail As Object
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.To = color
.Subject = color
.Body = "Please find the attached file."
.Attachments.Add fileRoot & color & ".xlsx"
.Send
End With
Set outlookMail = Nothing
Set outlookApp = Nothing
Next color
End Sub
```
该代码会遍历WS2的所有行,根据B列的颜色创建新的工作簿,并且将相同颜色的行复制到新的工作簿中。然后,该代码会使用Outlook应用程序创建并发送电子邮件,其中每个颜色都会生成一个电子邮件,并且附件将是以该颜色命名的工作簿。