Sub ReadAndWriteData
()
Call GetFilePaths
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wstarget, wstarget2 As Worksheet
Dim filePath As String
Dim lastCol, lastrow As Long
Dim i As Long
filePath
= ThisWorkbook
.Sheets
("Config"
).Range("B
1"
).Value
Set wb
= Workbooks
.Open
(filePath
)
Set wsSource
= wb
.Sheets
("SAMPLE MATRIX"
)
Set wstarget
= ThisWorkbook
.Sheets
("Sheet
1"
)
Set wstarget2
= ThisWorkbook
.Sheets
("Sheet2"
)
wstarget
.Cells.Clear
wstarget2
.Cells.Clear
lastCol
= wsSource
.Cells(2, Columns
.Count
).End
(xlToLeft
).Column
For i
= 6 To lastCol
wstarget
.Cells(i -
5,
1).Value = wsSource
.Cells(2, i
).Value
wstarget
.Cells(i -
5, 3
).Value = wsSource
.Cells(4, i
).Value
Next i
lastrow
= wsSource
.Range("A" & Rows
.Count
).End
(xlUp
).row
wsSource
.Range("A
5:E" & lastrow
).Copy
wstarget2
.Range("A
1"
).PasteSpecial Paste:
=xlPasteAll
Application
.CutCopyMode
= False
wb
.Close SaveChanges:
=False
Call get_Price
End Sub
Sub get_Price
()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wstarget As Worksheet
Dim filePath As String
Dim lastCol As Long
Dim i, j As Long
filePath
= ThisWorkbook
.Sheets
("Config"
).Range("B2"
).Value
Set wb
= Workbooks
.Open
(filePath
)
Set wsSource
= wb
.Sheets
("Quote Template to client"
)
Set wstarget
= ThisWorkbook
.Sheets
("Sheet
1"
)
lastrow_source
= wsSource
.Cells(Rows
.Count, 2
).End
(xlUp
).row
lastrow_target
= wstarget
.Cells(Rows
.Count,
1).End
(xlUp
).row
For i
= 1 To lastrow_target
For j
= 1 To lastrow_source
If wstarget
.Cells(i,
1).Value = wsSource
.Cells(j, 2
).Value Then
wstarget
.Cells(i, 2
).Value = wsSource
.Cells(j, 4
).Value
wstarget
.Cells(i, 4
).Value = wstarget
.Cells(i, 2
).Value * wstarget
.Cells(i, 3
).Value
End If
Next j
Next i
wb
.Close
Call EmbedTableAsPicture
End Sub
'inser_pic
Sub EmbedTableAsPicture
()
Dim wstarget, wstable, wsresult As Worksheet
Dim lastrow, lastrowtable, rowindex, i, TotalSum As Long
Set wstarget
= ThisWorkbook
.Sheets
("Sheet
1"
)
Set wstable
= ThisWorkbook
.Sheets
("TableData"
)
Set wsresult
= ThisWorkbook
.Sheets
("result"
)
wsresult
.Cells.Clear
wsresult
.Cells(1,
1).Value = "Test"
wsresult
.Cells(1, 2
).Value = "Discounted price
(USD
)"
wsresult
.Cells(1, 3
).Value = "Group"
wsresult
.Cells(1, 4
).Value = "Sub-Total Cost
(USD
)"
wsresult
.Cells(1,
5).Value = "Remarks
(Material no
.)"
wsresult
.Range("E
1:F
1"
).Merge
lastrow
= wstarget
.Cells(Rows
.Count,
1).End
(xlUp
).row
rowindex
= 2
TotalSum
= 0
For i
= 1 To lastrow
TotalSum
= TotalSum + wstarget
.Cells(i, 4
).Value
ExtractAndCreateNewSheet
(i +
5)
lastrowtable
= wstable
.Cells(Rows
.Count, 2
).End
(xlUp
).row
wsresult
.Cells(rowindex,
1).Value = wstarget
.Cells(i,
1).Value
wsresult
.Cells(rowindex, 2
).Value = "'$" & Str
(wstarget
.Cells(i, 2
).Value)
wsresult
.Cells(rowindex, 3
).Value = wstarget
.Cells(i, 3
).Value
wsresult
.Cells(rowindex, 4
).Value = "'$" & Str
(wstarget
.Cells(i, 4
).Value)
If lastrowtable
= 3 Then
wsresult
.Cells(rowindex,
5).Value = wstable
.Range("B3"
).Value
wsresult
.Range("E" & rowindex & ":F" & rowindex
).Merge
rowindex
= rowindex +
1
Else
wstable
.Range("A2:B" & lastrowtable
).Copy
wsresult
.Cells(rowindex,
5).PasteSpecial Paste:
=xlPasteAll
wsresult
.Range(Replace
("A" & rowindex & ":A" & Str
(rowindex + lastrowtable - 2
), " ", ""
)).Merge
wsresult
.Range(Replace
("B" & rowindex & ":B" & Str
(rowindex + lastrowtable - 2
), " ", ""
)).Merge
wsresult
.Range(Replace
("C" & rowindex & ":C" & Str
(rowindex + lastrowtable - 2
), " ", ""
)).Merge
wsresult
.Range(Replace
("D" & rowindex & ":D" & Str
(rowindex + lastrowtable - 2
), " ", ""
)).Merge
rowindex
= rowindex + lastrowtable -
1
End If
Next i
wsresult
.Cells(rowindex, 3
).Value = "TotalSum"
wsresult
.Cells(rowindex, 4
).Value = "'$" & Str
(TotalSum
)
wsresult
.Range("A:A"
).ColumnWidth
= 2
5
Call SendEmailWithFormattedTables
(Str
(TotalSum
))
End Sub
Function ExtractAndCreateNewSheet
(colTest
)
Dim wb As Workbook
Dim wsSource, wsNew As Worksheet
Dim lastrow, lastrownew As Long
Dim i, flag As Long
Set wb
= Workbooks
.Open
(ThisWorkbook
.Sheets
("Config"
).Range("B
1"
).Value)
Set wsSource
= wb
.Sheets
("SAMPLE MATRIX"
)
lastrow
= wsSource
.Cells(wsSource
.Rows
.Count,
1).End
(xlUp
).row
Set wsNew
= ThisWorkbook
.Sheets
("TableData"
)
wsNew
.Cells.Clear
flag
= 0
For i
= 6 To lastrow
If wsSource
.Cells(i, colTest
).Value <> "" Then
lastrownew
= wsNew
.Cells(Rows
.Count, 2
).End
(xlUp
).row +
1
wsNew
.Cells(lastrownew +
1, 2
).Value = wsSource
.Cells(i,
1).Value
If flag <> wsSource
.Cells(i, colTest
).Value Then
flag
= wsSource
.Cells(i, colTest
).Value
wsNew
.Cells(lastrownew +
1,
1).Value = wsSource
.Cells(i, colTest
).Value
End If
End If
Next i
wsNew
.Cells(2,
1).Value = "Group"
wb
.Close SaveChanges:
=False
End Function
Function GetFormattedHTMLTable
(ws As Worksheet, tablewidth As String, backcolor As String
) As String
Dim htmlBody As String
Dim rng As
Range, row As
Range, cell As
Range
Dim rowStart As Long, rowEnd As Long, colStart As Long, colEnd As Long
Dim isHeader As Boolean
' 为表格添加宽度自适应样式
htmlBody
= "<table border
='
1' style
='border-collapse: collapse; width:" & tablewidth & "%;'>"
' 假设第一行是表头
For Each row In ws
.Used
Range.Rows
isHeader
= (row
.row
= ws
.Used
Range.row
)
htmlBody
= htmlBody & "<tr>"
For Each cell In row
.Cells
If cell
.Merge
Cells Then
With cell
.MergeArea
rowStart
= .row
rowEnd
= .row +
.Rows
.Count -
1
colStart
= .Column
colEnd
= .Column +
.Columns
.Count -
1
End With
If cell
.row
= rowStart And cell
.Column
= colStart Then
If isHeader Then
' 设置表头单元格背景色为浅绿色
htmlBody
= htmlBody & "<td rowspan
='" &
(rowEnd - rowStart +
1) & "' colspan
='" &
(colEnd - colStart +
1) & "' style
='width:" & cell
.EntireColumn
.ColumnWidth * 6 & "px;height:" & cell
.EntireRow.RowHeight & "px;background-color: " & backcolor & ";color:" & RGBToHex
(cell
.Font
.Color
) & ";font-family:" & cell
.Font
.Name & ";font-size:" & cell
.Font
.Size & "px;font-weight:bold;'>"
Else
htmlBody
= htmlBody & "<td rowspan
='" &
(rowEnd - rowStart +
1) & "' colspan
='" &
(colEnd - colStart +
1) & "' style
='width:" & cell
.EntireColumn
.ColumnWidth * 6 & "px;height:" & cell
.EntireRow.RowHeight & "px;background-color:" & RGBToHex
(cell
.Interior
.Color
) & ";color:" & RGBToHex
(cell
.Font
.Color
) & ";font-family:" & cell
.Font
.Name & ";font-size:" & cell
.Font
.Size & "px;'>"
End If
htmlBody
= htmlBody & cell
.Value
htmlBody
= htmlBody & "</td>"
Else
GoTo SkipCell
End If
Else
If isHeader Then
' 设置表头单元格背景色为浅绿色
htmlBody
= htmlBody & "<td style
='width:" & cell
.EntireColumn
.ColumnWidth * 6 & "px;height:" & cell
.EntireRow.RowHeight & "px;background-color: " & backcolor & ";color:" & RGBToHex
(cell
.Font
.Color
) & ";font-family:" & cell
.Font
.Name & ";font-size:" & cell
.Font
.Size & "px;font-weight:bold;'>"
Else
htmlBody
= htmlBody & "<td style
='width:" & cell
.EntireColumn
.ColumnWidth * 6 & "px;height:" & cell
.EntireRow.RowHeight & "px;background-color:" & RGBToHex
(cell
.Interior
.Color
) & ";color:" & RGBToHex
(cell
.Font
.Color
) & ";font-family:" & cell
.Font
.Name & ";font-size:" & cell
.Font
.Size & "px;'>"
End If
htmlBody
= htmlBody & cell
.Value
htmlBody
= htmlBody & "</td>"
End If
SkipCell:
Next cell
htmlBody
= htmlBody & "</tr>"
Next row
htmlBody
= htmlBody & "</table>"
GetFormattedHTMLTable
= htmlBody
End Function
Function RGBToHex
(rgb As Long
) As String
If rgb
= -4
142 Then
RGBToHex
= "inherit"
Else
RGBToHex
= Right$
("000000" & Hex
(rgb
), 6
)
RGBToHex
= "#" & Mid
(RGBToHex,
5, 2
) & Mid
(RGBToHex, 3, 2
) & Mid
(RGBToHex,
1, 2
)
End If
End Function
Sub SendEmailWithFormattedTables
(TotalSum As String
)
Dim olApp As Object
Dim olMail As Object
Dim folderPath As String
Dim file As String
Dim htmlBody
1 As String
Dim htmlBody2 As String
Dim htmlImgTags As String
Dim imgCount As Integer
Dim extensions As Variant
Dim ext As Variant
' 获取文件夹路径
folderPath
= ThisWorkbook
.Sheets
("Config"
).Range("B3"
).Value
htmlBody2
= GetFormattedHTMLTable
(ThisWorkbook
.Sheets
("result"
), "60", "#DAEFC3"
)
htmlBody
1 = GetFormattedHTMLTable
(ThisWorkbook
.Sheets
("Sheet2"
), "70", "#92D0
50"
)
Set olApp
= CreateObject
("Outlook
.Application"
)
Set olMail
= olApp
.CreateItem
(0
)
' 定义图片扩展名数组
extensions
= Array
("jpg", "png"
)
' 遍历所有图片扩展名
For Each ext In extensions
file
= Dir
(folderPath & "\*
." & ext
)
Do While file <> ""
imgCount
= imgCount +
1
htmlImgTags
= htmlImgTags & "<br><img src
='cid:Image" & imgCount & "' width
='400' height
='2
50'><br>"
With olMail
.Attachments
.Add folderPath & "\" & file, olBy
Value, 0
.Attachments
(.Attachments
.Count
).PropertyAccessor
.Set
Property _
"http://schemas
.microsoft
.com/mapi/proptag/0x37
1200
1F", "Image" & imgCount
End With
file
= Dir
Loop
Next ext
With olMail
.To
= ThisWorkbook
.Sheets
("Config"
).Range("B4"
).Value
.Subject
= ThisWorkbook
.Sheets
("Config"
).Range("B
5"
).Value
.htmlBody
= "<html><body>Please find below quotation and confirm by return email, thank you
. <br>" & _
htmlBody
1 & "<span style
='color:#0099FF'><br>Model: 22739 <br>AE: Toys 3+</span><br> " & _
htmlBody2 & "<br><span style
='color:#0099FF'>Ref
. Photo</span> " & htmlImgTags & "</body></html>"
.Display
End With
Set olMail
= Nothing
Set olApp
= Nothing
End Sub
'get filepath
Sub GetFilePaths
()
Dim p As String, f As String
p
= ThisWorkbook
.Path & "\File Folder\"
f
= Dir
(p & "*
.xlsm"
)
If f <> "" Then
Cells(1, 2
) = p & f
f
= Dir
(p & "*
.xlsx"
)
If f <> "" Then
Cells(2, 2
) = p & f
Cells(3, 2
) = ThisWorkbook
.Path & "\File Folder"
End Sub
在不影响功能的前提下，把删减多余内容的代码发给我
扫一扫
1488
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
